From b426f287389c590a9431902273e5017ef9ef5b23 Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 12 Jun 2009 01:29:34 -0700 Subject: [PATCH 01/27] make m^n private --- basis/math/matrices/matrices.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 61e98ee444..21d9a97adf 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -61,8 +61,11 @@ PRIVATE> : cross-zip ( seq1 seq2 -- seq1xseq2 ) [ [ 2array ] with map ] curry map ; + + \ No newline at end of file From 9ffbf32c6f94a71f37c11c0032f16ba74392d521 Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 12 Jun 2009 01:35:25 -0700 Subject: [PATCH 02/27] unit test for m^n --- basis/math/matrices/matrices-tests.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor index 20942356de..3ee1ddbd6d 100644 --- a/basis/math/matrices/matrices-tests.factor +++ b/basis/math/matrices/matrices-tests.factor @@ -106,4 +106,7 @@ USING: math.matrices math.vectors tools.test math ; [ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test [ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ] -[ { 1 2 } { "a" "b" } cross-zip ] unit-test \ No newline at end of file +[ { 1 2 } { "a" "b" } cross-zip ] unit-test + +[ { { 4181 6765 } { 6765 10946 } } ] +[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test From 6a658506085fae99c827d7c7a4a1f714bb45cbc0 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 22 Jun 2009 23:06:07 +0200 Subject: [PATCH 03/27] WIP: crude xt>name disassembler help --- basis/tools/disassembler/udis/udis.factor | 9 +++-- basis/tools/disassembler/utils/utils.factor | 41 +++++++++++++++++++++ 2 files changed, 47 insertions(+), 3 deletions(-) create mode 100644 basis/tools/disassembler/utils/utils.factor diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index df624cab28..2f0456ab62 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -3,7 +3,8 @@ USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.order alien.libraries -math.parser system make fry arrays libc destructors ; +math.parser system make fry arrays libc destructors +tools.disassembler.utils splitting ; IN: tools.disassembler.udis << @@ -103,19 +104,21 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ; dup UD_SYN_INTEL ud_set_syntax ; : with-ud ( quot: ( ud -- ) -- ) - [ [ ] dip call ] with-destructors ; inline + [ [ [ ] dip call ] with-destructors ] with-words-xt ; inline SINGLETON: udis-disassembler : buf/len ( from to -- buf len ) [ drop ] [ swap - ] 2bi ; +: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ; + : format-disassembly ( lines -- lines' ) dup [ second length ] [ max ] map-reduce '[ [ [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ] [ second _ CHAR: \s pad-tail % " " % ] - [ third % ] + [ third resolve-call % ] tri ] "" make ] map ; diff --git a/basis/tools/disassembler/utils/utils.factor b/basis/tools/disassembler/utils/utils.factor new file mode 100644 index 0000000000..fb936cf08a --- /dev/null +++ b/basis/tools/disassembler/utils/utils.factor @@ -0,0 +1,41 @@ +USING: accessors arrays binary-search kernel math math.order +math.parser namespaces sequences sorting splitting vectors vocabs words ; +IN: tools.disassembler.utils + +SYMBOL: words-xt +SYMBOL: smallest-xt +SYMBOL: greatest-xt + +: (words-xt) ( -- assoc ) + vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map + [ [ first ] bi@ <=> ] sort >vector ; + +: complete-address ( n seq -- str ) + [ first - ] [ third name>> ] bi + over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ; + +: search-xt ( n -- str/f ) + dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [ + drop f + ] [ + words-xt get over [ swap first <=> ] curry search nip + 2dup second <= [ + [ complete-address ] [ drop f ] if* + ] [ + 2drop f + ] if + ] if ; + +: resolve-xt ( str -- str' ) + [ "0x" prepend ] [ 16 base> ] bi + [ search-xt [ " (" ")" surround append ] when* ] when* ; + +: resolve-call ( str -- str' ) + "0x" split1-last [ resolve-xt "0x" glue ] when* ; + +: with-words-xt ( quot -- ) + [ (words-xt) + [ words-xt set ] + [ first first smallest-xt set ] + [ last second greatest-xt set ] tri + ] prepose with-scope ; inline From d26735c98f1887c0de61bf4f62b82f440d644b92 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 10:29:41 -0500 Subject: [PATCH 04/27] mark integer sequence methods as deprecated --- core/sequences/sequences.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 177a157994..90103a79f9 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -98,9 +98,9 @@ M: f like drop [ f ] when-empty ; inline INSTANCE: f immutable-sequence -! Integers support the sequence protocol -M: integer length ; inline -M: integer nth-unsafe drop ; inline +! Integers used to support the sequence protocol +M: integer length ; inline deprecated +M: integer nth-unsafe drop ; inline deprecated INSTANCE: integer immutable-sequence From 8a9d0e13bbfd821d12d0a0ecaec7b2f4fd50e473 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 11:15:23 -0500 Subject: [PATCH 05/27] deprecate , and make malloc-array box its returned buffer in a direct array --- basis/alien/c-types/c-types-docs.factor | 10 ++++++---- basis/alien/c-types/c-types.factor | 4 ++-- basis/specialized-arrays/functor/functor.factor | 3 +++ 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index f5f9e004c4..e7083a2a3a 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -49,12 +49,11 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: +{ $deprecated "New code should use " { $link } " or the " { $vocab-link "specialized-arrays" } " vocabularies." } { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } { $errors "Throws an error if the type does not exist or the requested size is negative." } ; -{ malloc-array } related-words - HELP: { $values { "type" "a C type" } { "array" byte-array } } { $description "Creates a byte array suitable for holding a value with the given C type." } @@ -73,9 +72,10 @@ HELP: byte-array>memory HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } -{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." } +{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } +{ $notes "The appropriate direct 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-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ; +{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; HELP: malloc-object { $values { "type" "a C type" } { "alien" alien } } @@ -89,6 +89,8 @@ HELP: malloc-byte-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if memory allocation fails." } ; +{ malloc-array } related-words + HELP: box-parameter { $values { "n" integer } { "ctype" string } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 4c3c8d1668..6b56f52232 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -254,13 +254,13 @@ M: f byte-length drop 0 ; inline ] unless* ; : ( n type -- array ) - heap-size * ; inline + heap-size * ; inline deprecated : ( type -- array ) 1 swap ; inline : malloc-array ( n type -- alien ) - heap-size calloc ; inline + [ heap-size calloc ] [ ] 2bi ; inline : malloc-object ( type -- alien ) 1 swap malloc-array ; inline diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 3341a909d2..f5aca7fb95 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -13,6 +13,9 @@ M: bad-byte-array-length summary : (c-array) ( n c-type -- array ) heap-size * (byte-array) ; inline +: ( n type -- array ) + heap-size * ; inline + FUNCTOR: define-array ( T -- ) A DEFINES-CLASS ${T}-array From 2eff5542735dc37fa072096c73b145e4bb1ae628 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 12:22:55 -0500 Subject: [PATCH 06/27] update cocoa and core-foundation stuff to use classes.struct and boxed malloc-arrays --- basis/cocoa/enumeration/enumeration.factor | 19 ++--- basis/cocoa/messages/messages.factor | 17 ++--- basis/cocoa/runtime/runtime.factor | 8 +- basis/cocoa/types/types.factor | 24 +++--- basis/cocoa/views/views.factor | 2 +- basis/core-foundation/core-foundation.factor | 14 ++-- .../core-foundation/fsevents/fsevents.factor | 18 ++--- basis/core-graphics/types/types.factor | 73 +++++++++---------- basis/core-text/core-text.factor | 4 +- 9 files changed, 83 insertions(+), 96 deletions(-) diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index 1f9430e443..9da68e368b 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,27 +1,28 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel cocoa cocoa.types alien.c-types locals math -sequences vectors fry libc destructors -specialized-arrays.direct.alien ; +USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types +locals math sequences vectors fry libc destructors ; IN: cocoa.enumeration +<< "id" require-c-type-arrays >> + CONSTANT: NS-EACH-BUFFER-SIZE 16 : with-enumeration-buffers ( quot -- ) '[ - "NSFastEnumerationState" malloc-object &free + NSFastEnumerationState malloc-struct &free NS-EACH-BUFFER-SIZE "id" malloc-array &free NS-EACH-BUFFER-SIZE @ ] with-destructors ; inline :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) - object state stackbuf count -> countByEnumeratingWithState:objects:count: - dup 0 = [ drop ] [ - state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* - swap quot each + object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count + items-count 0 = [ + state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items + items-count iota [ items nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) - ] if ; inline recursive + ] unless ; inline recursive : NSFastEnumeration-each ( object quot -- ) [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 9da285f34c..fe003c32e1 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -continuations combinators compiler compiler.alien stack-checker kernel -math namespaces make quotations sequences strings words -cocoa.runtime io macros memoize io.encodings.utf8 effects libc -libc.private lexer init core-foundation fry generalizations -specialized-arrays.direct.alien ; +classes.struct continuations combinators compiler compiler.alien +stack-checker kernel math namespaces make quotations sequences +strings words cocoa.runtime io macros memoize io.encodings.utf8 +effects libc libc.private lexer init core-foundation fry +generalizations specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize bi ; : ( receiver -- super ) - "objc-super" [ - [ dup object_getClass class_getSuperclass ] dip - set-objc-super-class - ] keep - [ set-objc-super-receiver ] keep ; + [ ] [ object_getClass class_getSuperclass ] bi + objc-super ; TUPLE: selector name object ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 7817d0006c..28d812a489 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: cocoa.runtime TYPEDEF: void* SEL @@ -17,9 +17,9 @@ TYPEDEF: void* Class TYPEDEF: void* Method TYPEDEF: void* Protocol -C-STRUCT: objc-super - { "id" "receiver" } - { "Class" "class" } ; +STRUCT: objc-super + { receiver id } + { class Class } ; CONSTANT: CLS_CLASS HEX: 1 CONSTANT: CLS_META HEX: 2 diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 6e03a21bbc..0e0ef72ad2 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax combinators kernel layouts -core-graphics.types ; +classes.struct core-graphics.types ; IN: cocoa.types TYPEDEF: long NSInteger @@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize TYPEDEF: CGRect NSRect TYPEDEF: NSRect _NSRect -C-STRUCT: NSRange - { "NSUInteger" "location" } - { "NSUInteger" "length" } ; +STRUCT: NSRange + { location NSUInteger } + { length NSUInteger } ; TYPEDEF: NSRange _NSRange @@ -27,13 +27,11 @@ TYPEDEF: int long32 TYPEDEF: uint ulong32 TYPEDEF: void* unknown_type -: ( length location -- size ) - "NSRange" - [ set-NSRange-length ] keep - [ set-NSRange-location ] keep ; +: ( location length -- size ) + NSRange ; -C-STRUCT: NSFastEnumerationState - { "ulong" "state" } - { "id*" "itemsPtr" } - { "ulong*" "mutationsPtr" } - { "ulong[5]" "extra" } ; +STRUCT: NSFastEnumerationState + { state ulong } + { itemsPtr id* } + { mutationsPtr ulong* } + { extra ulong[5] } ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index ce785dd8df..badcac5cdb 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222 : mouse-location ( view event -- loc ) [ -> locationInWindow f -> convertPoint:fromView: - [ CGPoint-x ] [ CGPoint-y ] bi + [ x>> ] [ y>> ] bi ] [ drop -> frame CGRect-h ] 2bi swap - [ >integer ] bi@ 2array ; diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 82f836f28e..63bfaf37ce 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.c-types alien.destructors accessors kernel ; +USING: alien.syntax alien.c-types alien.destructors accessors classes.struct kernel ; IN: core-foundation TYPEDEF: void* CFTypeRef @@ -20,17 +20,15 @@ TYPEDEF: void* CFUUIDRef ALIAS: ALIAS: *CFIndex *long -C-STRUCT: CFRange -{ "CFIndex" "location" } -{ "CFIndex" "length" } ; +STRUCT: CFRange + { location CFIndex } + { length CFIndex } ; : ( location length -- range ) - "CFRange" - [ set-CFRange-length ] keep - [ set-CFRange-location ] keep ; + CFRange ; FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; FUNCTION: void CFRelease ( CFTypeRef cf ) ; -DESTRUCTOR: CFRelease \ No newline at end of file +DESTRUCTOR: CFRelease diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 4aa531f182..4b2cce994a 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators io.encodings.utf8 destructors locals -arrays specialized-arrays.direct.alien +arrays specialized-arrays.direct.alien classes.struct specialized-arrays.direct.int specialized-arrays.direct.longlong core-foundation core-foundation.run-loop core-foundation.strings core-foundation.time ; @@ -26,12 +26,12 @@ TYPEDEF: int FSEventStreamEventFlags TYPEDEF: longlong FSEventStreamEventId TYPEDEF: void* FSEventStreamRef -C-STRUCT: FSEventStreamContext - { "CFIndex" "version" } - { "void*" "info" } - { "void*" "retain" } - { "void*" "release" } - { "void*" "copyDescription" } ; +STRUCT: FSEventStreamContext + { version CFIndex } + { info void* } + { retain void* } + { release void* } + { copyDescription void* } ; ! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]); TYPEDEF: void* FSEventStreamCallback @@ -104,8 +104,8 @@ FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ; FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ; : make-FSEventStreamContext ( info -- alien ) - "FSEventStreamContext" - [ set-FSEventStreamContext-info ] keep ; + FSEventStreamContext + swap >>info ; :: ( callback info paths latency flags -- event-stream ) f ! allocator diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index 0acdad9c0c..ad4620e174 100644 --- a/basis/core-graphics/types/types.factor +++ b/basis/core-graphics/types/types.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel layouts +USING: accessors alien.c-types alien.syntax classes.struct kernel layouts math math.rectangles arrays ; IN: core-graphics.types @@ -12,63 +12,56 @@ IN: core-graphics.types : *CGFloat ( alien -- x ) cell 4 = [ *float ] [ *double ] if ; inline -C-STRUCT: CGPoint - { "CGFloat" "x" } - { "CGFloat" "y" } ; +STRUCT: CGPoint + { x CGFloat } + { y CGFloat } ; : ( x y -- point ) - "CGPoint" - [ set-CGPoint-y ] keep - [ set-CGPoint-x ] keep ; + CGPoint ; -C-STRUCT: CGSize - { "CGFloat" "w" } - { "CGFloat" "h" } ; +STRUCT: CGSize + { w CGFloat } + { h CGFloat } ; : ( w h -- size ) - "CGSize" - [ set-CGSize-h ] keep - [ set-CGSize-w ] keep ; + CGSize ; -C-STRUCT: CGRect - { "CGPoint" "origin" } - { "CGSize" "size" } ; +STRUCT: CGRect + { origin CGPoint } + { size CGSize } ; : CGPoint>loc ( CGPoint -- loc ) - [ CGPoint-x ] [ CGPoint-y ] bi 2array ; + [ x>> ] [ y>> ] bi 2array ; : CGSize>dim ( CGSize -- dim ) - [ CGSize-w ] [ CGSize-h ] bi 2array ; + [ w>> ] [ h>> ] bi 2array ; : CGRect>rect ( CGRect -- rect ) - [ CGRect-origin CGPoint>loc ] - [ CGRect-size CGSize>dim ] + [ origin>> CGPoint>loc ] + [ size>> CGSize>dim ] bi ; inline : CGRect-x ( CGRect -- x ) - CGRect-origin CGPoint-x ; inline + origin>> x>> ; inline : CGRect-y ( CGRect -- y ) - CGRect-origin CGPoint-y ; inline + origin>> y>> ; inline : CGRect-w ( CGRect -- w ) - CGRect-size CGSize-w ; inline + size>> w>> ; inline : CGRect-h ( CGRect -- h ) - CGRect-size CGSize-h ; inline + size>> h>> ; inline : set-CGRect-x ( x CGRect -- ) - CGRect-origin set-CGPoint-x ; inline + origin>> (>>x) ; inline : set-CGRect-y ( y CGRect -- ) - CGRect-origin set-CGPoint-y ; inline + origin>> (>>y) ; inline : set-CGRect-w ( w CGRect -- ) - CGRect-size set-CGSize-w ; inline + size>> (>>w) ; inline : set-CGRect-h ( h CGRect -- ) - CGRect-size set-CGSize-h ; inline + size>> (>>h) ; inline : ( x y w h -- rect ) - "CGRect" - [ set-CGRect-h ] keep - [ set-CGRect-w ] keep - [ set-CGRect-y ] keep - [ set-CGRect-x ] keep ; + [ CGPoint ] [ CGSize ] 2bi* + CGRect ; : CGRect-x-y ( alien -- origin-x origin-y ) [ CGRect-x ] [ CGRect-y ] bi ; @@ -76,13 +69,13 @@ C-STRUCT: CGRect : CGRect-top-left ( alien -- x y ) [ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ; -C-STRUCT: CGAffineTransform - { "CGFloat" "a" } - { "CGFloat" "b" } - { "CGFloat" "c" } - { "CGFloat" "d" } - { "CGFloat" "tx" } - { "CGFloat" "ty" } ; +STRUCT: CGAffineTransform + { a CGFloat } + { b CGFloat } + { c CGFloat } + { d CGFloat } + { tx CGFloat } + { ty CGFloat } ; TYPEDEF: void* CGColorRef TYPEDEF: void* CGColorSpaceRef diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 52f4eb5e2e..99849c1666 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -116,8 +116,8 @@ TUPLE: line < disposable line metrics image loc dim ; line [ string open-font font foreground>> |CFRelease ] rect [ line line-rect ] - (loc) [ rect CGRect-origin CGPoint>loc ] - (dim) [ rect CGRect-size CGSize>dim ] + (loc) [ rect origin>> CGPoint>loc ] + (dim) [ rect size>> CGSize>dim ] (ext) [ (loc) (dim) v+ ] loc [ (loc) [ floor ] map ] ext [ (loc) (dim) [ + ceiling ] 2map ] From 64baa58a3d8a5fabb9e9bf632dfcb76045d7b9ad Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 12:23:09 -0500 Subject: [PATCH 07/27] typo in alien.c-types docs --- basis/alien/c-types/c-types-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index e7083a2a3a..cd0f90f81c 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -73,7 +73,7 @@ HELP: byte-array>memory HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } -{ $notes "The appropriate direct 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-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; +{ $notes "The appropriate direct 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-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; From 0e8fe01d11279b97cbfd03c87e3db0a93943b11b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 12:45:59 -0500 Subject: [PATCH 08/27] change malloc-object and not to be in terms of malloc-array and --- basis/alien/c-types/c-types.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6b56f52232..8a1b60a0db 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -257,13 +257,16 @@ M: f byte-length drop 0 ; inline heap-size * ; inline deprecated : ( type -- array ) - 1 swap ; inline + heap-size ; inline + +: (c-object) ( type -- array ) + heap-size (byte-array) ; inline : malloc-array ( n type -- alien ) [ heap-size calloc ] [ ] 2bi ; inline : malloc-object ( type -- alien ) - 1 swap malloc-array ; inline + heap-size malloc ; inline : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; From e5897d52b26cc6196e73e41f8c29eb155b14ebcb Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 29 Aug 2009 21:42:15 +0200 Subject: [PATCH 09/27] Ensure that random-prime result has the right size As noted by Slava, choosing the next prime following a random number with a specified number of bits may give a number one more bit long. --- basis/math/primes/primes.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 7e877a03ce..27743a4a85 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -56,7 +56,8 @@ PRIVATE> : coprime? ( a b -- ? ) gcd nip 1 = ; foldable : random-prime ( numbits -- p ) - random-bits* next-prime ; + [ ] [ 2^ ] [ random-bits* next-prime ] tri + 2dup < [ 2drop random-prime ] [ 2nip ] if ; : estimated-primes ( m -- n ) dup log / ; foldable From a71f242578c02bd24360f097c7649bb648a90145 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 15:28:31 -0500 Subject: [PATCH 10/27] change malloc-object back to using calloc --- basis/alien/c-types/c-types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 8a1b60a0db..13607566e0 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -266,7 +266,7 @@ M: f byte-length drop 0 ; inline [ heap-size calloc ] [ ] 2bi ; inline : malloc-object ( type -- alien ) - heap-size malloc ; inline + 1 swap heap-size calloc ; inline : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; From 4e7bada863c2988c25e477419f4fb8bd6cde1408 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 17:17:25 -0500 Subject: [PATCH 11/27] use calloc in malloc-struct for consistency with malloc-object and malloc-array --- basis/classes/struct/struct.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 2cafb5e8fe..88c207f418 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -45,7 +45,7 @@ M: struct equal? ] 1 define-partial-eval : malloc-struct ( class -- struct ) - [ heap-size malloc ] keep memory>struct ; inline + [ 1 swap heap-size calloc ] keep memory>struct ; inline : (struct) ( class -- struct ) [ heap-size ] keep memory>struct ; inline From 51405868d1c8fd970f29f0bff7cf0e97fdcc96e8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 17:41:21 -0500 Subject: [PATCH 12/27] ignore deprecations in words that are themselves deprecated --- basis/tools/deprecation/deprecation.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index ff6a7ef51a..0ee60b06b5 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -1,5 +1,6 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays assocs compiler.units debugger init io +USING: accessors arrays assocs combinators.short-circuit +compiler.units debugger init io io.streams.null kernel namespaces prettyprint sequences source-files.errors summary tools.crossref tools.crossref.private tools.errors words ; @@ -41,7 +42,7 @@ T{ error-type : check-deprecations ( usage -- ) dup word? [ - dup "forgotten" word-prop + dup { [ "forgotten" word-prop ] [ deprecated? ] } 1|| [ clear-deprecation-note ] [ dup def>> uses [ deprecated? ] filter [ clear-deprecation-note ] [ >array deprecation-note ] if-empty From 4cc2330a2a9239d019b45db76b6143040e7473cf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 19:56:42 -0500 Subject: [PATCH 13/27] add STRUCT: support to functors --- basis/functors/functors-tests.factor | 65 +++++++++++++++++++++++++++- basis/functors/functors.factor | 39 +++++++++++++++-- 2 files changed, 99 insertions(+), 5 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a21313312b..a8d97927f8 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,5 +1,5 @@ -USING: functors tools.test math words kernel multiline parser -io.streams.string generic ; +USING: classes.struct functors tools.test math words kernel +multiline parser io.streams.string generic ; IN: functors.tests << @@ -151,3 +151,64 @@ SYMBOL: W-symbol test-redefinition +<< + +FUNCTOR: define-a-struct ( T NAME TYPE N -- ) + +T-class DEFINES-CLASS ${T} + +WHERE + +STRUCT: T-class + { NAME int } + { "x" { TYPE 4 } } + { "y" { "short" N } } + { "z" TYPE initial: 5 } + { "w" { "int" 2 } } ; + +;FUNCTOR + +"a-struct" "nemo" "char" 2 define-a-struct + +>> + +[ + { + T{ struct-slot-spec + { name "nemo" } + { offset 0 } + { class integer } + { initial 0 } + { c-type "int" } + } + T{ struct-slot-spec + { name "x" } + { offset 4 } + { class object } + { initial f } + { c-type { "char" 4 } } + } + T{ struct-slot-spec + { name "y" } + { offset 8 } + { class object } + { initial f } + { c-type { "short" 2 } } + } + T{ struct-slot-spec + { name "z" } + { offset 12 } + { class fixnum } + { initial 5 } + { c-type "char" } + } + T{ struct-slot-spec + { name "w" } + { offset 16 } + { class object } + { initial f } + { c-type { "int" 2 } } + } + } +] [ a-struct struct-slots ] unit-test + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 5f519aeece..befe3aa174 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.mixin classes.parser -classes.singleton classes.tuple classes.tuple.parser +classes.singleton classes.struct classes.tuple classes.tuple.parser combinators effects.parser fry generic generic.parser generic.standard interpolate io.streams.string kernel lexer -locals.parser locals.types macros make namespaces parser -quotations sequences vocabs.parser words words.symbol ; +locals locals.parser locals.types macros make namespaces parser +quotations sequences slots vectors vocabs.parser words words.symbol ; IN: functors ! This is a hack @@ -58,6 +58,32 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; +: scan-c-type* ( -- c-type/param ) + scan { + { [ dup "{" = ] [ drop \ } parse-until >array ] } + { [ dup search ] [ search ] } + [ ] + } cond ; + +:: parse-struct-slot* ( accum -- accum ) + scan-param :> name + scan-c-type* :> c-type + \ } parse-until :> attributes + accum { + \ struct-slot-spec new + name >>name + c-type [ >>c-type ] [ struct-slot-class >>class ] bi + attributes [ dup empty? ] [ peel-off-attributes ] until drop + over push + } over push-all ; + +: parse-struct-slots* ( accum -- accum more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot* t ] } + [ invalid-struct-slot ] + } case ; + SYNTAX: `TUPLE: scan-param parsed scan { @@ -71,6 +97,12 @@ SYNTAX: `TUPLE: } case \ define-tuple-class parsed ; +SYNTAX: `STRUCT: + scan-param parsed + [ 8 ] over push-all + [ parse-struct-slots* ] [ ] while + [ >array define-struct-class ] over push-all ; + SYNTAX: `SINGLETON: scan-param parsed \ define-singleton-class parsed ; @@ -147,6 +179,7 @@ DEFER: ;FUNCTOR delimiter : functor-words ( -- assoc ) H{ { "TUPLE:" POSTPONE: `TUPLE: } + { "STRUCT:" POSTPONE: `STRUCT: } { "SINGLETON:" POSTPONE: `SINGLETON: } { "MIXIN:" POSTPONE: `MIXIN: } { "M:" POSTPONE: `M: } From 309b11213c317248b2cd440cc7a191e89bb9ec51 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 19:58:07 -0500 Subject: [PATCH 14/27] correct some classes.struct docs --- basis/classes/struct/struct-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 2b27672018..bcc77f1b25 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -40,13 +40,13 @@ HELP: UNION-STRUCT: HELP: define-struct-class { $values - { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ; HELP: define-union-struct-class { $values - { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ; @@ -55,7 +55,7 @@ HELP: malloc-struct { "class" class } { "struct" struct } } -{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ; +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ; HELP: memory>struct { $values From 2e3f75fd8783fdabb27b77b2cc00c70927245958 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 20:19:47 -0500 Subject: [PATCH 15/27] fix STRUCT: functor when a slot name is the same as a non-lexical word name --- basis/functors/functors-tests.factor | 12 ++++++------ basis/functors/functors.factor | 14 ++++++++------ 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a8d97927f8..bcdc1bae74 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -161,10 +161,10 @@ WHERE STRUCT: T-class { NAME int } - { "x" { TYPE 4 } } - { "y" { "short" N } } - { "z" TYPE initial: 5 } - { "w" { "int" 2 } } ; + { x { TYPE 4 } } + { y { "short" N } } + { z TYPE initial: 5 } + { float { "float" 2 } } ; ;FUNCTOR @@ -203,11 +203,11 @@ STRUCT: T-class { c-type "char" } } T{ struct-slot-spec - { name "w" } + { name "float" } { offset 16 } { class object } { initial f } - { c-type { "int" 2 } } + { c-type { "float" 2 } } } } ] [ a-struct struct-slots ] unit-test diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index befe3aa174..dcfd140e92 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -58,15 +58,17 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; +: >string-param ( string -- string/param ) + dup search dup lexical? [ nip ] [ drop ] if ; + : scan-c-type* ( -- c-type/param ) - scan { - { [ dup "{" = ] [ drop \ } parse-until >array ] } - { [ dup search ] [ search ] } - [ ] - } cond ; + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +: scan-string-param ( -- name/param ) + scan >string-param ; :: parse-struct-slot* ( accum -- accum ) - scan-param :> name + scan-string-param :> name scan-c-type* :> c-type \ } parse-until :> attributes accum { From db7eb4e27a5b340594caa8adccf41691249b2a32 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 20:20:25 -0500 Subject: [PATCH 16/27] change alien.complex to use struct classes --- basis/alien/complex/complex-tests.factor | 15 +++++++------- basis/alien/complex/functor/functor.factor | 23 +++++++++------------- 2 files changed, 16 insertions(+), 22 deletions(-) diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 2844e505b5..7bf826d87e 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -1,22 +1,21 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.complex kernel alien.c-types alien.syntax -namespaces math ; +USING: accessors tools.test alien.complex classes.struct kernel +alien.c-types alien.syntax namespaces math ; IN: alien.complex.tests -C-STRUCT: complex-holder - { "complex-float" "z" } ; +STRUCT: complex-holder + { z complex-float } ; : ( z -- alien ) - "complex-holder" - [ set-complex-holder-z ] keep ; + complex-holder ; [ ] [ C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test +[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test [ number ] [ "complex-float" c-type-boxed-class ] unit-test -[ number ] [ "complex-double" c-type-boxed-class ] unit-test \ No newline at end of file +[ number ] [ "complex-double" c-type-boxed-class ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 7727546c00..cb66175a29 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,33 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.c-types math math.functions sequences -arrays kernel functors vocabs.parser namespaces accessors -quotations ; +USING: accessors alien.structs alien.c-types classes.struct math +math.functions sequences arrays kernel functors vocabs.parser +namespaces quotations ; IN: alien.complex.functor FUNCTOR: define-complex-type ( N T -- ) -T-real DEFINES ${T}-real -T-imaginary DEFINES ${T}-imaginary -set-T-real DEFINES set-${T}-real -set-T-imaginary DEFINES set-${T}-imaginary +T-class DEFINES-CLASS ${T} DEFINES <${T}> *T DEFINES *${T} WHERE +STRUCT: T-class { real N } { imaginary N } ; + : ( z -- alien ) - >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + >rect T-class ; : *T ( alien -- z ) - [ T-real ] [ T-imaginary ] bi rect> ; inline + T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline -T current-vocab -{ { N "real" } { N "imaginary" } } -define-struct - -T c-type +T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot number >>boxed-class From 7276fe44d70d9636e2c355fc8e8a6d01bb30383e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 21:04:19 -0500 Subject: [PATCH 17/27] refactor functors so that new functor syntax words can be added outside of functors vocab, and move STRUCT: functor syntax to classes.struct to break a circular dependency --- basis/classes/struct/struct.factor | 38 +++++++++-- basis/functors/backend/backend.factor | 33 +++++++++ basis/functors/functors.factor | 96 +++++---------------------- 3 files changed, 84 insertions(+), 83 deletions(-) create mode 100644 basis/functors/backend/backend.factor diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 88c207f418..45ad3c62bb 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -2,11 +2,11 @@ USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays byte-arrays classes classes.parser classes.tuple classes.tuple.parser classes.tuple.private -combinators combinators.short-circuit combinators.smart fry -generalizations generic.parser kernel kernel.private lexer -libc macros make math math.order parser quotations sequences -slots slots.private struct-arrays vectors words -compiler.tree.propagation.transforms ; +combinators combinators.short-circuit combinators.smart +functors.backend fry generalizations generic.parser kernel +kernel.private lexer libc locals macros make math math.order parser +quotations sequences slots slots.private struct-arrays vectors +words compiler.tree.propagation.transforms ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -259,6 +259,34 @@ SYNTAX: UNION-STRUCT: SYNTAX: S{ scan-word dup struct-slots parse-tuple-literal-slots parsed ; +: scan-c-type` ( -- c-type/param ) + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +:: parse-struct-slot` ( accum -- accum ) + scan-string-param :> name + scan-c-type` :> c-type + \ } parse-until :> attributes + accum { + \ struct-slot-spec new + name >>name + c-type [ >>c-type ] [ struct-slot-class >>class ] bi + attributes [ dup empty? ] [ peel-off-attributes ] until drop + over push + } over push-all ; + +: parse-struct-slots` ( accum -- accum more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot` t ] } + [ invalid-struct-slot ] + } case ; + +FUNCTOR-SYNTAX: STRUCT: + scan-param parsed + [ 8 ] over push-all + [ parse-struct-slots` ] [ ] while + [ >array define-struct-class ] over push-all ; + USING: vocabs vocabs.loader ; "prettyprint" vocab [ "classes.struct.prettyprint" require ] when diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor new file mode 100644 index 0000000000..dd3d891f7b --- /dev/null +++ b/basis/functors/backend/backend.factor @@ -0,0 +1,33 @@ +USING: accessors arrays assocs generic.standard kernel +lexer locals.types namespaces parser quotations vocabs.parser +words ; +IN: functors.backend + +DEFER: functor-words +\ functor-words [ H{ } clone ] initialize + +SYNTAX: FUNCTOR-SYNTAX: + scan-word + gensym [ parse-definition define-syntax ] keep + swap name>> \ functor-words get-global set-at ; + +: functor-words ( -- assoc ) + \ functor-words get-global ; + +: scan-param ( -- obj ) scan-object literalize ; + +: >string-param ( string -- string/param ) + dup search dup lexical? [ nip ] [ drop ] if ; + +: scan-string-param ( -- name/param ) + scan >string-param ; + +: scan-c-type-param ( -- c-type/param ) + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +: define* ( word def -- ) over set-word define ; + +: define-declared* ( word def effect -- ) pick set-word define-declared ; + +: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ; + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index dcfd140e92..62654ece79 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,25 +1,17 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.mixin classes.parser -classes.singleton classes.struct classes.tuple classes.tuple.parser -combinators effects.parser fry generic generic.parser -generic.standard interpolate io.streams.string kernel lexer -locals locals.parser locals.types macros make namespaces parser -quotations sequences slots vectors vocabs.parser words words.symbol ; +classes.singleton classes.tuple classes.tuple.parser +combinators effects.parser fry functors.backend generic +generic.parser interpolate io.streams.string kernel lexer +locals.parser locals.types macros make namespaces parser +quotations sequences vocabs.parser words words.symbol ; IN: functors ! This is a hack ) , ; [ parse-definition* ] dip parsed ; -: >string-param ( string -- string/param ) - dup search dup lexical? [ nip ] [ drop ] if ; - -: scan-c-type* ( -- c-type/param ) - scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; - -: scan-string-param ( -- name/param ) - scan >string-param ; - -:: parse-struct-slot* ( accum -- accum ) - scan-string-param :> name - scan-c-type* :> c-type - \ } parse-until :> attributes - accum { - \ struct-slot-spec new - name >>name - c-type [ >>c-type ] [ struct-slot-class >>class ] bi - attributes [ dup empty? ] [ peel-off-attributes ] until drop - over push - } over push-all ; - -: parse-struct-slots* ( accum -- accum more? ) - scan { - { ";" [ f ] } - { "{" [ parse-struct-slot* t ] } - [ invalid-struct-slot ] - } case ; - -SYNTAX: `TUPLE: +FUNCTOR-SYNTAX: TUPLE: scan-param parsed scan { { ";" [ tuple parsed f parsed ] } @@ -99,66 +63,60 @@ SYNTAX: `TUPLE: } case \ define-tuple-class parsed ; -SYNTAX: `STRUCT: - scan-param parsed - [ 8 ] over push-all - [ parse-struct-slots* ] [ ] while - [ >array define-struct-class ] over push-all ; - -SYNTAX: `SINGLETON: +FUNCTOR-SYNTAX: SINGLETON: scan-param parsed \ define-singleton-class parsed ; -SYNTAX: `MIXIN: +FUNCTOR-SYNTAX: MIXIN: scan-param parsed \ define-mixin-class parsed ; -SYNTAX: `M: +FUNCTOR-SYNTAX: M: scan-param parsed scan-param parsed [ create-method-in dup method-body set ] over push-all parse-definition* \ define* parsed ; -SYNTAX: `C: +FUNCTOR-SYNTAX: C: scan-param parsed scan-param parsed complete-effect [ [ [ boa ] curry ] over push-all ] dip parsed \ define-declared* parsed ; -SYNTAX: `: +FUNCTOR-SYNTAX: : scan-param parsed parse-declared* \ define-declared* parsed ; -SYNTAX: `SYMBOL: +FUNCTOR-SYNTAX: SYMBOL: scan-param parsed \ define-symbol parsed ; -SYNTAX: `SYNTAX: +FUNCTOR-SYNTAX: SYNTAX: scan-param parsed parse-definition* \ define-syntax parsed ; -SYNTAX: `INSTANCE: +FUNCTOR-SYNTAX: INSTANCE: scan-param parsed scan-param parsed \ add-mixin-instance parsed ; -SYNTAX: `GENERIC: +FUNCTOR-SYNTAX: GENERIC: scan-param parsed complete-effect parsed \ define-simple-generic* parsed ; -SYNTAX: `MACRO: +FUNCTOR-SYNTAX: MACRO: scan-param parsed parse-declared* \ define-macro parsed ; -SYNTAX: `inline [ word make-inline ] over push-all ; +FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ; -SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; +FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ; : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip @@ -178,24 +136,6 @@ DEFER: ;FUNCTOR delimiter Date: Sat, 29 Aug 2009 21:23:35 -0500 Subject: [PATCH 18/27] benchmark.struct-arrays: doesn't actually need HINTS: --- extra/benchmark/struct-arrays/struct-arrays.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/extra/benchmark/struct-arrays/struct-arrays.factor b/extra/benchmark/struct-arrays/struct-arrays.factor index 827604a39e..faed2f4dca 100644 --- a/extra/benchmark/struct-arrays/struct-arrays.factor +++ b/extra/benchmark/struct-arrays/struct-arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes.struct combinators.smart fry kernel math math.functions math.order math.parser sequences -struct-arrays hints io ; +struct-arrays io ; IN: benchmark.struct-arrays STRUCT: point { x float } { y float } { z float } ; @@ -45,8 +45,6 @@ STRUCT: point { x float } { y float } { z float } ; : struct-array-benchmark ( len -- ) make-points [ normalize-points ] [ max-points ] bi print-point ; -HINTS: struct-array-benchmark fixnum ; - : main ( -- ) 5000000 struct-array-benchmark ; MAIN: main From dca528eaef4fa5cab9262642ed6c697394a627e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Aug 2009 22:09:51 -0500 Subject: [PATCH 19/27] benchmark.terrain-generation: fix type error --- extra/benchmark/terrain-generation/terrain-generation.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/terrain-generation/terrain-generation.factor b/extra/benchmark/terrain-generation/terrain-generation.factor index 7fbb0ff43f..623a905bbc 100644 --- a/extra/benchmark/terrain-generation/terrain-generation.factor +++ b/extra/benchmark/terrain-generation/terrain-generation.factor @@ -4,7 +4,7 @@ IN: benchmark.terrain-generation : terrain-generation-benchmark ( -- ) "Generating terrain segment..." write flush yield - { 0.0 0.0 } terrain-segment drop + { 0 0 } terrain-segment drop "done" print ; MAIN: terrain-generation-benchmark From 3e51bde4845d429ed7e462643985f8f7e158e29c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:40:13 -0500 Subject: [PATCH 20/27] change malloc-struct to initialize struct from initial values; add (malloc-struct) and (struct) words that leave their memory uninitialized --- basis/classes/struct/struct-docs.factor | 21 ++++++++++++++++++++- basis/classes/struct/struct-tests.factor | 2 +- basis/classes/struct/struct.factor | 17 +++++++++++------ 3 files changed, 32 insertions(+), 8 deletions(-) diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index bcc77f1b25..787f03423e 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -9,6 +9,15 @@ HELP: } { $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ; +HELP: (struct) +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link } " word, which initializes the struct's slots with their initial values, should be used instead." } ; + +{ (struct) (malloc-struct) } related-words + HELP: { $values { "class" class } @@ -55,7 +64,14 @@ HELP: malloc-struct { "class" class } { "struct" struct } } -{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ; +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ; + +HELP: (malloc-struct) +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ; HELP: memory>struct { $values @@ -80,6 +96,9 @@ ARTICLE: "classes.struct" "Struct classes" { $subsection } { $subsection malloc-struct } { $subsection memory>struct } +"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:" +{ $subsection (struct) } +{ $subsection (malloc-struct) } "Structs have literal syntax like tuples:" { $subsection POSTPONE: S{ } "Union structs are also supported, which behave like structs but share the same memory for all the type's slots." diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 2995e9d6d6..52e766a682 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -63,7 +63,7 @@ UNION-STRUCT: struct-test-float-and-bits [ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test -[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test +[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test STRUCT: struct-test-string-ptr { x char* } ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 45ad3c62bb..94eebca081 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -37,6 +37,8 @@ M: struct equal? [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ] } 2&& ; +: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable + : memory>struct ( ptr class -- struct ) [ 1array ] dip slots>tuple ; @@ -44,17 +46,20 @@ M: struct equal? dup struct-class? [ '[ _ boa ] ] [ drop f ] if ] 1 define-partial-eval +: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien ) + '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline + +: (malloc-struct) ( class -- struct ) + [ heap-size malloc ] keep memory>struct ; inline + : malloc-struct ( class -- struct ) - [ 1 swap heap-size calloc ] keep memory>struct ; inline + [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; : (struct) ( class -- struct ) - [ heap-size ] keep memory>struct ; inline - -: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable + [ heap-size (byte-array) ] keep memory>struct ; inline : ( class -- struct ) - dup struct-prototype - [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline + [ >c-ptr clone ] [ heap-size ] (init-struct) ; MACRO: ( class -- quot: ( ... -- struct ) ) [ From 4d8ed23db5e6cd0ec309ef06bedd309e91609233 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:42:48 -0500 Subject: [PATCH 21/27] add non-initializing (malloc-array) and (malloc-object) for kicks --- basis/alien/c-types/c-types.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 13607566e0..d75a4898c5 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -265,9 +265,15 @@ M: f byte-length drop 0 ; inline : malloc-array ( n type -- alien ) [ heap-size calloc ] [ ] 2bi ; inline +: (malloc-array) ( n type -- alien ) + [ heap-size * malloc ] [ ] 2bi ; inline + : malloc-object ( type -- alien ) 1 swap heap-size calloc ; inline +: (malloc-object) ( type -- alien ) + heap-size malloc ; inline + : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; From 20aa00f8df1363c212b1c452ddfecbddf70ed11e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:54:56 -0500 Subject: [PATCH 22/27] implement clone on struct classes to copy the struct contents --- basis/classes/struct/struct-tests.factor | 4 +++- basis/classes/struct/struct.factor | 3 +++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 52e766a682..0cd91da370 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,5 +1,5 @@ ! (c)Joe Groff bsd license -USING: accessors alien.c-types alien.libraries +USING: accessors alien alien.c-types alien.libraries alien.structs.fields alien.syntax ascii classes.struct combinators destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math multiline namespaces prettyprint @@ -203,3 +203,5 @@ STRUCT: struct-test-optimization ] unit-test [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test + +[ f ] [ struct-test-foo dup clone [ >c-ptr ] bi@ eq? ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 94eebca081..4cb275f86f 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -46,6 +46,9 @@ M: struct equal? dup struct-class? [ '[ _ boa ] ] [ drop f ] if ] 1 define-partial-eval +M: struct clone + [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ; + : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien ) '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline From 32f014a030041203a5bae592e42522d9bb8e24cb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:59:13 -0500 Subject: [PATCH 23/27] privatize classes.struct's shameful bits --- basis/classes/struct/struct.factor | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 4cb275f86f..4238230e16 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -49,8 +49,10 @@ M: struct equal? M: struct clone [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ; +struct ; inline +PRIVATE> : (malloc-struct) ( class -- struct ) [ heap-size malloc ] keep memory>struct ; inline @@ -74,6 +76,7 @@ MACRO: ( class -- quot: ( ... -- struct ) ) ] bi ] [ ] output>sequence ; +> ] map over length tail append ] keep ; @@ -90,6 +93,7 @@ MACRO: ( class -- quot: ( ... -- struct ) ) : (unboxer-quot) ( class -- quot ) drop [ >c-ptr ] ; +PRIVATE> M: struct-class boa>object swap pad-struct-slots @@ -106,6 +110,7 @@ M: struct-class reader-quot M: struct-class writer-quot nip (writer-quot) ; +> reader-word 1quotation ] map @@ -120,8 +125,6 @@ M: struct-class writer-quot [ \ byte-length create-method-in ] [ heap-size \ drop swap [ ] 2sequence ] bi define ; -! Struct as c-type - : slot>field ( slot -- field ) field-spec new swap { [ name>> >>name ] @@ -163,6 +166,7 @@ M: struct-class writer-quot : struct-align ( slots -- align ) [ c-type>> c-type-align ] [ max ] map-reduce ; +PRIVATE> M: struct-class c-type name>> c-type ; @@ -188,6 +192,7 @@ M: struct-class heap-size ! class definition + ] [ memory>struct ] @@ -227,6 +232,7 @@ M: struct-class heap-size (struct-word-props) ] [ drop define-struct-for-class ] 2tri ; inline +PRIVATE> : define-struct-class ( class slots -- ) [ struct-offsets ] (define-struct-class) ; @@ -236,6 +242,7 @@ M: struct-class heap-size ERROR: invalid-struct-slot token ; + [ parse-struct-slots ] [ ] while >array ; +PRIVATE> SYNTAX: STRUCT: parse-struct-definition define-struct-class ; @@ -267,6 +275,9 @@ SYNTAX: UNION-STRUCT: SYNTAX: S{ scan-word dup struct-slots parse-tuple-literal-slots parsed ; +! functor support + +array ] [ >string-param ] if ; @@ -288,6 +299,7 @@ SYNTAX: S{ { "{" [ parse-struct-slot` t ] } [ invalid-struct-slot ] } case ; +PRIVATE> FUNCTOR-SYNTAX: STRUCT: scan-param parsed From be406fa9649dac538f6ae80bc1108368f8a49ca3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 23:18:31 -0500 Subject: [PATCH 24/27] fix alien.complex unboxer --- basis/alien/complex/functor/functor.factor | 4 ++-- basis/classes/struct/struct.factor | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index cb66175a29..b05059e9cb 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.structs alien.c-types classes.struct math +USING: accessors alien alien.structs alien.c-types classes.struct math math.functions sequences arrays kernel functors vocabs.parser namespaces quotations ; IN: alien.complex.functor @@ -17,7 +17,7 @@ WHERE STRUCT: T-class { real N } { imaginary N } ; : ( z -- alien ) - >rect T-class ; + >rect T-class >c-ptr ; : *T ( alien -- z ) T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 4238230e16..99150e9bb6 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -110,6 +110,8 @@ M: struct-class reader-quot M: struct-class writer-quot nip (writer-quot) ; +! c-types + Date: Sun, 30 Aug 2009 17:29:40 +0900 Subject: [PATCH 25/27] Better error images for non-baseline JPEGs. bugfix: Handles more than one table per DHT chunk. --- basis/images/jpeg/jpeg.factor | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 776f768036..f0280e46de 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files io.streams.byte-array kernel locals math math.bitwise math.constants math.functions math.matrices math.order math.ranges math.vectors memoize multiline namespaces -sequences sequences.deep images.loader ; +sequences sequences.deep images.loader io.streams.limited ; IN: images.jpeg QUALIFIED-WITH: bitstreams bs @@ -118,18 +118,18 @@ TUPLE: jpeg-color-info ] with-byte-reader ; : decode-huff-table ( chunk -- ) - data>> - binary - [ - 1 ! %fixme: Should handle multiple tables at once + data>> [ binary ] [ length ] bi + stream-throws limit + [ + [ input-stream get [ count>> ] [ limit>> ] bi < ] [ read4/4 swap 2 * + 16 read dup [ ] [ + ] map-reduce read binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader swap jpeg> huff-tables>> set-nth - ] times - ] with-byte-reader ; + ] while + ] with-input-stream* ; : decode-scan ( chunk -- ) data>> @@ -148,7 +148,10 @@ TUPLE: jpeg-color-info : singleton-first ( seq -- elt ) [ length 1 assert= ] [ first ] bi ; +ERROR: not-a-baseline-jpeg-image ; + : baseline-parse ( -- ) + jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless jpeg> headers>> { [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ] @@ -221,7 +224,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; : V.M ( x A -- x.A ) Mtranspose swap M.V ; : idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ; -: idct ( b -- b' ) idct-blas ; +: idct ( b -- b' ) idct-factor ; :: draw-block ( block x,y color-id jpeg-image -- ) block dup length>> sqrt >fixnum group flip From 0db01f6d5f27e01eb2d6b03b588ed1c65016473a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 04:52:01 -0500 Subject: [PATCH 26/27] compiler.cfg.linear-scan now supports partial sync-points where all registers are spilled; taking advantage of this, there are new trigonometric intrinsics which yield a 2x performance boost on benchmark.struct-arrays and a 25% boost on benchmark.partial-sums --- .../build-stack-frame.factor | 13 +-- basis/compiler/cfg/hats/hats.factor | 2 + .../cfg/instructions/instructions.factor | 13 +++ .../cfg/intrinsics/float/float.factor | 6 ++ .../compiler/cfg/intrinsics/intrinsics.factor | 37 +++++++ .../linear-scan/allocation/allocation.factor | 42 ++++++-- .../allocation/spilling/spilling.factor | 4 +- .../linear-scan/allocation/state/state.factor | 13 ++- .../linear-scan/assignment/assignment.factor | 32 +++--- .../cfg/linear-scan/debugger/debugger.factor | 1 + .../live-intervals/live-intervals.factor | 100 +++++++++++------- .../expressions/expressions.factor | 15 +++ basis/compiler/codegen/codegen.factor | 6 ++ basis/compiler/tests/codegen.factor | 9 +- basis/cpu/architecture/architecture.factor | 2 + basis/cpu/x86/64/64.factor | 20 ++++ basis/math/libm/libm.factor | 33 +++--- 17 files changed, 257 insertions(+), 91 deletions(-) diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 0155ea519d..90992fcc96 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -14,13 +14,12 @@ GENERIC: compute-stack-frame* ( insn -- ) frame-required? on stack-frame [ max-stack-frame ] change ; -M: ##alien-invoke compute-stack-frame* - stack-frame>> request-stack-frame ; +UNION: stack-frame-insn + ##alien-invoke + ##alien-indirect + ##alien-callback ; -M: ##alien-indirect compute-stack-frame* - stack-frame>> request-stack-frame ; - -M: ##alien-callback compute-stack-frame* +M: stack-frame-insn compute-stack-frame* stack-frame>> request-stack-frame ; M: ##call compute-stack-frame* @@ -40,6 +39,8 @@ M: insn compute-stack-frame* ] when ; \ _spill t frame-required? set-word-prop +\ ##unary-float-function t frame-required? set-word-prop +\ ##binary-float-function t frame-required? set-word-prop : compute-stack-frame ( insns -- ) frame-required? off diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index d0b2cd4d9e..1eb7c01671 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -47,6 +47,8 @@ IN: compiler.cfg.hats : ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline : ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline : ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline +: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline +: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline : ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline : ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline : ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 9706507193..eb358f0437 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -112,6 +112,10 @@ INSN: ##min-float < ##binary ; INSN: ##max-float < ##binary ; INSN: ##sqrt < ##unary ; +! libc intrinsics +INSN: ##unary-float-function < ##unary func ; +INSN: ##binary-float-function < ##binary func ; + ! Float/integer conversion INSN: ##float>integer < ##unary ; INSN: ##integer>float < ##unary ; @@ -252,6 +256,11 @@ UNION: vreg-insn _compare-imm-branch _dispatch ; +! Instructions that kill all live vregs but cannot trigger GC +UNION: partial-sync-insn + ##unary-float-function + ##binary-float-function ; + ! Instructions that kill all live vregs UNION: kill-vreg-insn ##call @@ -270,6 +279,8 @@ UNION: output-float-insn ##min-float ##max-float ##sqrt + ##unary-float-function + ##binary-float-function ##integer>float ##unbox-float ##alien-float @@ -284,6 +295,8 @@ UNION: input-float-insn ##min-float ##max-float ##sqrt + ##unary-float-function + ##binary-float-function ##float>integer ##box-float ##set-alien-float diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 9d0af29a15..fd4ca53d6c 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -18,3 +18,9 @@ IN: compiler.cfg.intrinsics.float : emit-fsqrt ( -- ) ds-pop ^^sqrt ds-push ; + +: emit-unary-float-function ( func -- ) + [ ds-pop ] dip ^^unary-float-function ds-push ; + +: emit-binary-float-function ( func -- ) + [ 2inputs ] dip ^^binary-float-function ds-push ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 562c3ad836..28d3243ba9 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -108,6 +108,27 @@ IN: compiler.cfg.intrinsics math.floats.private:float-max } enable-intrinsics ; +: enable-float-functions ( -- ) + ! Everything except for fsqrt + { + math.libm:facos + math.libm:fasin + math.libm:fatan + math.libm:fatan2 + math.libm:fcos + math.libm:fsin + math.libm:ftan + math.libm:fcosh + math.libm:fsinh + math.libm:ftanh + math.libm:fexp + math.libm:flog + math.libm:fpow + math.libm:facosh + math.libm:fasinh + math.libm:fatanh + } enable-intrinsics ; + : enable-min/max ( -- ) { math.integers.private:fixnum-min @@ -157,6 +178,22 @@ IN: compiler.cfg.intrinsics { \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] } { \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] } { \ math.libm:fsqrt [ drop emit-fsqrt ] } + { \ math.libm:facos [ drop "acos" emit-unary-float-function ] } + { \ math.libm:fasin [ drop "asin" emit-unary-float-function ] } + { \ math.libm:fatan [ drop "atan" emit-unary-float-function ] } + { \ math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] } + { \ math.libm:fcos [ drop "cos" emit-unary-float-function ] } + { \ math.libm:fsin [ drop "sin" emit-unary-float-function ] } + { \ math.libm:ftan [ drop "tan" emit-unary-float-function ] } + { \ math.libm:fcosh [ drop "cosh" emit-unary-float-function ] } + { \ math.libm:fsinh [ drop "sinh" emit-unary-float-function ] } + { \ math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } + { \ math.libm:fexp [ drop "exp" emit-unary-float-function ] } + { \ math.libm:flog [ drop "log" emit-unary-float-function ] } + { \ math.libm:fpow [ drop "pow" emit-binary-float-function ] } + { \ 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 ] } { \ slots.private:slot [ emit-slot ] } { \ slots.private:set-slot [ emit-set-slot ] } { \ strings.private:string-nth [ drop emit-string-nth ] } diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 4b504d97f5..c23867ffe2 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs heaps kernel namespaces sequences fry math -math.order combinators arrays sorting compiler.utilities +math.order combinators arrays sorting compiler.utilities locals compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation.spilling compiler.cfg.linear-scan.allocation.splitting @@ -34,22 +34,48 @@ IN: compiler.cfg.linear-scan.allocation [ drop assign-blocked-register ] } cond ; -: handle-interval ( live-interval -- ) - [ - start>> +: handle-sync-point ( n -- ) + [ active-intervals get values ] dip + [ '[ [ _ spill ] each ] each ] + [ drop [ delete-all ] each ] + 2bi ; + +:: handle-progress ( n sync? -- ) + n { [ progress set ] [ deactivate-intervals ] - [ activate-intervals ] tri - ] [ assign-register ] bi ; + [ sync? [ handle-sync-point ] [ drop ] if ] + [ activate-intervals ] + } cleave ; + +GENERIC: handle ( obj -- ) + +M: live-interval handle ( live-interval -- ) + [ start>> f handle-progress ] [ assign-register ] bi ; + +M: sync-point handle ( sync-point -- ) + n>> t handle-progress ; + +: smallest-heap ( heap1 heap2 -- heap ) + ! If heap1 and heap2 have the same key, favors heap1. + [ [ heap-peek nip ] bi@ <= ] most ; : (allocate-registers) ( -- ) - unhandled-intervals get [ handle-interval ] slurp-heap ; + { + { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] } + { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] } + ! If a live interval begins at the same location as a sync point, + ! process the sync point before the live interval. This ensures that the + ! return value of C function calls doesn't get spilled and reloaded + ! unnecessarily. + [ unhandled-sync-points get unhandled-intervals get smallest-heap ] + } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ; : finish-allocation ( -- ) active-intervals inactive-intervals [ get values [ handled-intervals get push-all ] each ] bi@ ; -: allocate-registers ( live-intervals machine-registers -- live-intervals ) +: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals ) init-allocator init-unhandled (allocate-registers) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 4dd3c8176c..11874a567f 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -29,7 +29,7 @@ ERROR: bad-live-ranges interval ; 2bi ; : assign-spill ( live-interval -- ) - dup vreg>> assign-spill-slot >>spill-to drop ; + dup vreg>> vreg-spill-slot >>spill-to drop ; : spill-before ( before -- before/f ) ! If the interval does not have any usages before the spill location, @@ -46,7 +46,7 @@ ERROR: bad-live-ranges interval ; ] if ; : assign-reload ( live-interval -- ) - dup vreg>> assign-spill-slot >>reload-from drop ; + dup vreg>> vreg-spill-slot >>reload-from drop ; : spill-after ( after -- after/f ) ! If the interval has no more usages after the spill location, diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index cf120eae3b..a311f97b66 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -120,15 +120,19 @@ SYMBOL: unhandled-intervals rep-size cfg get [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; +! Minheap of sync points which still need to be processed +SYMBOL: unhandled-sync-points + ! Mapping from vregs to spill slots SYMBOL: spill-slots -: assign-spill-slot ( vreg -- n ) +: vreg-spill-slot ( vreg -- n ) spill-slots get [ rep-of next-spill-slot ] cache ; : init-allocator ( registers -- ) registers set unhandled-intervals set + unhandled-sync-points set [ V{ } clone ] reg-class-assoc active-intervals set [ V{ } clone ] reg-class-assoc inactive-intervals set V{ } clone handled-intervals set @@ -136,9 +140,10 @@ SYMBOL: spill-slots H{ } clone spill-slots set -1 progress set ; -: init-unhandled ( live-intervals -- ) - [ [ start>> ] keep ] { } map>assoc - unhandled-intervals get heap-push-all ; +: init-unhandled ( live-intervals sync-points -- ) + [ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ] + [ [ [ n>> ] keep ] { } map>assoc unhandled-sync-points get heap-push-all ] + bi* ; ! A utility used by register-status and spill-status words : free-positions ( new -- assoc ) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 16f1ccf96a..03df2d9747 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -28,6 +28,20 @@ SYMBOL: pending-interval-assoc : remove-pending ( live-interval -- ) vreg>> pending-interval-assoc get delete-at ; +: (vreg>reg) ( vreg pending -- reg ) + ! If a live vreg is not in the pending set, then it must + ! have been spilled. + ?at [ spill-slots get at ] unless ; + +: vreg>reg ( vreg -- reg ) + pending-interval-assoc get (vreg>reg) ; + +: vregs>regs ( vregs -- assoc ) + dup assoc-empty? [ + pending-interval-assoc get + '[ _ (vreg>reg) ] assoc-map + ] unless ; + ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -96,8 +110,6 @@ SYMBOL: register-live-outs GENERIC: assign-registers-in-insn ( insn -- ) -: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ; - RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ] M: vreg-insn assign-registers-in-insn @@ -123,7 +135,7 @@ M: vreg-insn assign-registers-in-insn [ [ 2dup spill-on-gc? - [ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if + [ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if ] assoc-each ] { } make ; @@ -137,23 +149,13 @@ M: ##gc assign-registers-in-insn M: insn assign-registers-in-insn drop ; -: compute-live-values ( vregs -- assoc ) - ! If a live vreg is not in active or inactive, then it must have been - ! spilled. - dup assoc-empty? [ - pending-interval-assoc get - '[ _ ?at [ ] [ spill-slots get at ] if ] assoc-map - ] unless ; - : begin-block ( bb -- ) dup basic-block set dup block-from activate-new-intervals - [ live-in compute-live-values ] keep - register-live-ins get set-at ; + [ live-in vregs>regs ] keep register-live-ins get set-at ; : end-block ( bb -- ) - [ live-out compute-live-values ] keep - register-live-outs get set-at ; + [ live-out vregs>regs ] keep register-live-outs get set-at ; ERROR: bad-vreg vreg ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index 68ff8d4f88..fa248dd4e8 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -9,6 +9,7 @@ IN: compiler.cfg.linear-scan.debugger [ [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc live-intervals set + f ] dip allocate-registers drop ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 2301d26f80..520518d27a 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -32,9 +32,12 @@ M: live-interval covers? ( insn# live-interval -- ? ) ERROR: dead-value-error vreg ; +: add-new-range ( from to live-interval -- ) + [ ] dip ranges>> push ; + : shorten-range ( n live-interval -- ) dup ranges>> empty? - [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ; + [ dupd add-new-range ] [ ranges>> last (>>from) ] if ; : extend-range ( from to live-range -- ) ranges>> last @@ -42,9 +45,6 @@ ERROR: dead-value-error vreg ; [ min ] change-from drop ; -: add-new-range ( from to live-interval -- ) - [ ] dip ranges>> push ; - : extend-range? ( to live-interval -- ? ) ranges>> [ drop f ] [ last from>> >= ] if-empty ; @@ -52,8 +52,18 @@ ERROR: dead-value-error vreg ; 2dup extend-range? [ extend-range ] [ add-new-range ] if ; -: add-use ( n live-interval -- ) - uses>> push ; +GENERIC: operands-in-registers? ( insn -- ? ) + +M: vreg-insn operands-in-registers? drop t ; + +M: partial-sync-insn operands-in-registers? drop f ; + +: add-def ( insn live-interval -- ) + [ insn#>> ] [ uses>> ] bi* push ; + +: add-use ( insn live-interval -- ) + ! Every use is a potential def, no SSA here baby! + over operands-in-registers? [ add-def ] [ 2drop ] if ; : ( vreg -- live-interval ) \ live-interval new @@ -68,51 +78,68 @@ ERROR: dead-value-error vreg ; M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ; -M: live-interval clone - call-next-method [ clone ] change-uses ; - ! Mapping from vreg to live-interval SYMBOL: live-intervals -: live-interval ( vreg live-intervals -- live-interval ) - [ ] cache ; +: live-interval ( vreg -- live-interval ) + live-intervals get [ ] cache ; GENERIC: compute-live-intervals* ( insn -- ) M: insn compute-live-intervals* drop ; -: handle-output ( n vreg live-intervals -- ) +: handle-output ( insn vreg -- ) live-interval - [ add-use ] [ shorten-range ] 2bi ; + [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ; -: handle-input ( n vreg live-intervals -- ) +: handle-input ( insn vreg -- ) live-interval - [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ; + [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ; -: handle-temp ( n vreg live-intervals -- ) +: handle-temp ( insn vreg -- ) live-interval - [ dupd add-range ] [ add-use ] 2bi ; + [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ; M: vreg-insn compute-live-intervals* - dup insn#>> - live-intervals get - [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ] - [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ] - [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ] - 3tri ; + [ dup defs-vreg [ handle-output ] with when* ] + [ dup uses-vregs [ handle-input ] with each ] + [ dup temp-vregs [ handle-temp ] with each ] + tri ; : handle-live-out ( bb -- ) - live-out keys - basic-block get [ block-from ] [ block-to ] bi - live-intervals get '[ - [ _ _ ] dip _ live-interval add-range - ] each ; + [ block-from ] [ block-to ] [ live-out keys ] tri + [ live-interval add-range ] with with each ; + +! A location where all registers have to be spilled +TUPLE: sync-point n ; + +C: sync-point + +! Sequence of sync points +SYMBOL: sync-points + +GENERIC: compute-sync-points* ( insn -- ) + +M: partial-sync-insn compute-sync-points* + insn#>> sync-points get push ; + +M: insn compute-sync-points* drop ; : compute-live-intervals-step ( bb -- ) [ basic-block set ] [ handle-live-out ] - [ instructions>> [ compute-live-intervals* ] each ] tri ; + [ + instructions>> [ + [ compute-live-intervals* ] + [ compute-sync-points* ] + bi + ] each + ] tri ; +: init-live-intervals ( -- ) + H{ } clone live-intervals set + V{ } clone sync-points set ; + : compute-start/end ( live-interval -- ) dup ranges>> [ first from>> ] [ last to>> ] bi [ >>start ] [ >>end ] bi* drop ; @@ -122,10 +149,10 @@ ERROR: bad-live-interval live-interval ; : check-start ( live-interval -- ) dup start>> -1 = [ bad-live-interval ] [ drop ] if ; -: finish-live-intervals ( live-intervals -- ) +: finish-live-intervals ( live-intervals -- seq ) ! Since live intervals are computed in a backward order, we have ! to reverse some sequences, and compute the start and end. - [ + values dup [ { [ ranges>> reverse-here ] [ uses>> reverse-here ] @@ -134,12 +161,11 @@ ERROR: bad-live-interval live-interval ; } cleave ] each ; -: compute-live-intervals ( cfg -- live-intervals ) - H{ } clone [ - live-intervals set - linearization-order - [ compute-live-intervals-step ] each - ] keep values dup finish-live-intervals ; +: compute-live-intervals ( cfg -- live-intervals sync-points ) + init-live-intervals + linearization-order [ compute-live-intervals-step ] each + live-intervals get finish-live-intervals + sync-points get ; : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 ) [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 973a0a0dc1..e8488b8afb 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -12,6 +12,8 @@ TUPLE: commutative-expr < binary-expr ; TUPLE: compare-expr < binary-expr cc ; TUPLE: constant-expr < expr value ; TUPLE: reference-expr < expr value ; +TUPLE: unary-float-function-expr < expr in func ; +TUPLE: binary-float-function-expr < expr in1 in2 func ; TUPLE: box-displaced-alien-expr < expr displacement base base-class ; : ( constant -- expr ) @@ -94,6 +96,19 @@ M: ##box-displaced-alien >expr [ base-class>> ] } cleave box-displaced-alien-expr boa ; +M: ##unary-float-function >expr + [ class ] [ src>> vreg>vn ] [ func>> ] tri + unary-float-function-expr boa ; + +M: ##binary-float-function >expr + { + [ class ] + [ src1>> vreg>vn ] + [ src2>> vreg>vn ] + [ func>> ] + } cleave + binary-float-function-expr boa ; + M: ##flushable >expr drop next-input-expr ; : init-expressions ( -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index c0f793a7dc..83d7341a8e 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -176,6 +176,12 @@ M: ##max-float generate-insn dst/src1/src2 %max-float ; M: ##sqrt generate-insn dst/src %sqrt ; +M: ##unary-float-function generate-insn + [ dst/src ] [ func>> ] bi %unary-float-function ; + +M: ##binary-float-function generate-insn + [ dst/src1/src2 ] [ func>> ] bi %binary-float-function ; + M: ##integer>float generate-insn dst/src %integer>float ; M: ##float>integer generate-insn dst/src %float>integer ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index d45b4aa151..5155d13e99 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ math hashtables.private math.private namespaces sequences tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make alien.c-types combinators.short-circuit -math.order ; +math.order math.libm ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -407,4 +407,9 @@ cell 4 = [ : missing-gc-check-1 ( a -- b ) { fixnum } declare ; : missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ; -[ ] [ missing-gc-check-2 ] unit-test \ No newline at end of file +[ ] [ missing-gc-check-2 ] unit-test + +[ 1 0.169967142900241 ] [ 1.4 [ 1 swap fcos ] compile-call ] unit-test +[ 1 0.169967142900241 ] [ 1.4 1 [ swap fcos ] compile-call ] unit-test +[ 0.169967142900241 0.9854497299884601 ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call ] unit-test +[ 1 0.169967142900241 0.9854497299884601 ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call ] unit-test \ No newline at end of file diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index fc972229e8..35772f1b1a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -115,6 +115,8 @@ HOOK: %div-float cpu ( dst src1 src2 -- ) HOOK: %min-float cpu ( dst src1 src2 -- ) HOOK: %max-float cpu ( dst src1 src2 -- ) HOOK: %sqrt cpu ( dst src -- ) +HOOK: %unary-float-function cpu ( dst src func -- ) +HOOK: %binary-float-function cpu ( dst src1 src2 func -- ) HOOK: %integer>float cpu ( dst src -- ) HOOK: %float>integer cpu ( dst src -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index fbcb113e91..98a8b3bc24 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -197,6 +197,23 @@ M: x86.64 %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; +: float-function-param ( i spill-slot -- ) + [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ; + +: float-function-return ( reg -- ) + float-regs return-reg double-float-rep copy-register ; + +M:: x86.64 %unary-float-function ( dst src func -- ) + 0 src float-function-param + func f %alien-invoke + dst float-function-return ; + +M:: x86.64 %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 ; + ! The result of reading 4 bytes from memory is a fixnum on ! x86-64. enable-alien-4-intrinsics @@ -204,6 +221,9 @@ enable-alien-4-intrinsics ! SSE2 is always available on x86-64. enable-sse2 +! Enable fast calling of libc math functions +enable-float-functions + USE: vocabs.loader { diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor index d0a579e5f4..e2bd2ef6eb 100644 --- a/basis/math/libm/libm.factor +++ b/basis/math/libm/libm.factor @@ -4,54 +4,53 @@ USING: alien ; IN: math.libm : facos ( x -- y ) - "double" "libm" "acos" { "double" } alien-invoke ; inline + "double" "libm" "acos" { "double" } alien-invoke ; : fasin ( x -- y ) - "double" "libm" "asin" { "double" } alien-invoke ; inline + "double" "libm" "asin" { "double" } alien-invoke ; : fatan ( x -- y ) - "double" "libm" "atan" { "double" } alien-invoke ; inline + "double" "libm" "atan" { "double" } alien-invoke ; : fatan2 ( x y -- z ) - "double" "libm" "atan2" { "double" "double" } alien-invoke ; inline + "double" "libm" "atan2" { "double" "double" } alien-invoke ; : fcos ( x -- y ) - "double" "libm" "cos" { "double" } alien-invoke ; inline + "double" "libm" "cos" { "double" } alien-invoke ; : fsin ( x -- y ) - "double" "libm" "sin" { "double" } alien-invoke ; inline + "double" "libm" "sin" { "double" } alien-invoke ; : ftan ( x -- y ) - "double" "libm" "tan" { "double" } alien-invoke ; inline + "double" "libm" "tan" { "double" } alien-invoke ; : fcosh ( x -- y ) - "double" "libm" "cosh" { "double" } alien-invoke ; inline + "double" "libm" "cosh" { "double" } alien-invoke ; : fsinh ( x -- y ) - "double" "libm" "sinh" { "double" } alien-invoke ; inline + "double" "libm" "sinh" { "double" } alien-invoke ; : ftanh ( x -- y ) - "double" "libm" "tanh" { "double" } alien-invoke ; inline + "double" "libm" "tanh" { "double" } alien-invoke ; : fexp ( x -- y ) - "double" "libm" "exp" { "double" } alien-invoke ; inline + "double" "libm" "exp" { "double" } alien-invoke ; : flog ( x -- y ) - "double" "libm" "log" { "double" } alien-invoke ; inline + "double" "libm" "log" { "double" } alien-invoke ; : fpow ( x y -- z ) - "double" "libm" "pow" { "double" "double" } alien-invoke ; inline + "double" "libm" "pow" { "double" "double" } alien-invoke ; -! Don't inline fsqrt -- its an intrinsic! : fsqrt ( x -- y ) "double" "libm" "sqrt" { "double" } alien-invoke ; ! Windows doesn't have these... : facosh ( x -- y ) - "double" "libm" "acosh" { "double" } alien-invoke ; inline + "double" "libm" "acosh" { "double" } alien-invoke ; : fasinh ( x -- y ) - "double" "libm" "asinh" { "double" } alien-invoke ; inline + "double" "libm" "asinh" { "double" } alien-invoke ; : fatanh ( x -- y ) - "double" "libm" "atanh" { "double" } alien-invoke ; inline + "double" "libm" "atanh" { "double" } alien-invoke ; From 9595be4bf9c0d928f392b235cb01ca6685338ee2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 05:11:08 -0500 Subject: [PATCH 27/27] %box-displaced-alien: fix clobberage found by Doug --- basis/compiler/cfg/def-use/def-use.factor | 2 +- basis/compiler/cfg/hats/hats.factor | 2 +- .../cfg/instructions/instructions.factor | 2 +- .../cfg/renaming/functor/functor.factor | 4 +++- .../preferred/preferred.factor | 2 +- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/tests/intrinsics.factor | 8 ++++++++ basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/ppc/ppc.factor | 19 +++++++++++++++---- basis/cpu/x86/x86.factor | 14 ++++++++++---- .../struct-arrays/struct-arrays-tests.factor | 7 +++++++ 11 files changed, 49 insertions(+), 15 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index ca0c5df0fa..3102d75a4e 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -21,7 +21,7 @@ M: ##slot temp-vregs temp>> 1array ; M: ##set-slot temp-vregs temp>> 1array ; M: ##string-nth temp-vregs temp>> 1array ; M: ##set-string-nth-fast temp-vregs temp>> 1array ; -M: ##box-displaced-alien temp-vregs temp>> 1array ; +M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##compare temp-vregs temp>> 1array ; M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-float temp-vregs temp>> 1array ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 1eb7c01671..2d79cbebc3 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -58,7 +58,7 @@ IN: compiler.cfg.hats : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline : ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline : ^^box-displaced-alien ( base displacement base-class -- dst ) - ^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline + ^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline : ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline : ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ; : ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index eb358f0437..a7cc2e0603 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -126,7 +126,7 @@ INSN: ##unbox-float < ##unary ; INSN: ##unbox-any-c-ptr < ##unary/temp ; INSN: ##box-float < ##unary/temp ; INSN: ##box-alien < ##unary/temp ; -INSN: ##box-displaced-alien < ##binary temp base-class ; +INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ; : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor index 05e1015432..b307155091 100644 --- a/basis/compiler/cfg/renaming/functor/functor.factor +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -141,7 +141,9 @@ M: ##set-string-nth-fast rename-insn-temps TEMP-QUOT change-temp drop ; M: ##box-displaced-alien rename-insn-temps - TEMP-QUOT change-temp drop ; + TEMP-QUOT change-temp1 + TEMP-QUOT change-temp2 + drop ; M: ##compare rename-insn-temps TEMP-QUOT change-temp drop ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 7de2ff6c52..4b071ba5e2 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -25,7 +25,7 @@ M: ##slot temp-vreg-reps drop { int-rep } ; M: ##set-slot temp-vreg-reps drop { int-rep } ; M: ##string-nth temp-vreg-reps drop { int-rep } ; M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ; -M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ; +M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ; M: ##compare temp-vreg-reps drop { int-rep } ; M: ##compare-imm temp-vreg-reps drop { int-rep } ; M: ##compare-float temp-vreg-reps drop { int-rep } ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 83d7341a8e..00a36cc55f 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -193,7 +193,7 @@ M: ##box-float generate-insn dst/src/temp %box-float ; M: ##box-alien generate-insn dst/src/temp %box-alien ; M: ##box-displaced-alien generate-insn - [ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ; + [ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ; M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ; M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 23d26b0033..988164143f 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -519,6 +519,14 @@ cell 8 = [ underlying>> ] unit-test +[ ALIEN: 1234 ALIEN: 2234 ] [ + ALIEN: 234 [ + { c-ptr } declare + [ 1000 swap ] + [ 2000 swap ] bi + ] compile-call +] unit-test + [ B{ 0 0 0 0 } [ { byte-array } declare ] compile-call ] must-fail diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 35772f1b1a..c1c54be321 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -126,7 +126,7 @@ HOOK: %unbox-float cpu ( dst src -- ) HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) HOOK: %box-float cpu ( dst src temp -- ) HOOK: %box-alien cpu ( dst src temp -- ) -HOOK: %box-displaced-alien cpu ( dst displacement base temp -- ) +HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- ) HOOK: %alien-unsigned-1 cpu ( dst src -- ) HOOK: %alien-unsigned-2 cpu ( dst src -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index d21f5756b9..33619ca3e3 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -335,7 +335,7 @@ M:: ppc %box-alien ( dst src temp -- ) "f" resolve-label ] with-scope ; -M:: ppc %box-displaced-alien ( dst displacement base temp -- ) +M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- ) [ "end" define-label "ok" define-label @@ -343,7 +343,12 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- ) dst base MR 0 displacement 0 CMPI "end" get BEQ + ! Quickly use displacement' before its needed for real, as allot temporary + 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 temp base header-offset LWZ @@ -351,11 +356,17 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- ) "ok" get BNE ! displacement += base.displacement temp base 3 alien@ LWZ - displacement displacement temp ADD + displacement' displacement temp ADD ! base = base.base - base base 1 alien@ LWZ + base' base 1 alien@ LWZ "ok" resolve-label - dst displacement base temp %allot-alien + ! Store underlying-alien slot + base' dst 1 alien@ STW + ! Store offset + displacement' dst 3 alien@ STW + ! Store expired slot (its ok to clobber displacement') + temp \ f tag-number %load-immediate + temp dst 2 alien@ STW "end" resolve-label ] with-scope ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index da7b89de0b..630be55c67 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -278,7 +278,7 @@ M:: x86 %box-alien ( dst src temp -- ) "end" resolve-label ] with-scope ; -M:: x86 %box-displaced-alien ( dst displacement base temp -- ) +M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- ) [ "end" define-label "ok" define-label @@ -286,17 +286,23 @@ M:: x86 %box-displaced-alien ( dst displacement base temp -- ) dst base MOV displacement 0 CMP "end" get JE + ! Quickly use displacement' before its needed for real, as allot temporary + dst 4 cells alien displacement' %allot ! If base is already a displaced alien, unpack it + base' base MOV + displacement' displacement MOV base \ f tag-number CMP "ok" get JE base header-offset [+] alien type-number tag-fixnum CMP "ok" get JNE ! displacement += base.displacement - displacement base 3 alien@ ADD + displacement' base 3 alien@ ADD ! base = base.base - base base 1 alien@ MOV + base' base 1 alien@ MOV "ok" resolve-label - dst displacement base temp %allot-alien + dst 1 alien@ base' MOV ! alien + dst 2 alien@ \ f tag-number MOV ! expired + dst 3 alien@ displacement' MOV ! displacement "end" resolve-label ] with-scope ; diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 64639c7ca1..a57bb0259c 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -44,3 +44,10 @@ STRUCT: test-struct-array S{ test-struct-array f 20 20 } } second ] unit-test + +! Regression +STRUCT: fixed-string { text char[100] } ; + +[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ + ALIEN: 123 4 fixed-string [ (underlying)>> ] { } map-as +] unit-test