diff --git a/README.txt b/README.txt index 754791aa1a..98616539d2 100755 --- a/README.txt +++ b/README.txt @@ -43,13 +43,10 @@ Compilation will yield an executable named 'factor' on Unix, For X11 support, you need recent development libraries for libc, Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution -(like Ubuntu), you can use the line +(like Ubuntu), you can use the following line to grab everything: sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev -to grab everything (if you're on a non-debian-derived distro please tell -us what the equivalent command is on there and it can be added). - * Bootstrapping the Factor image Once you have compiled the Factor runtime, you must bootstrap the Factor diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index 09a09cdc6f..c5efe1e030 100644 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -1,69 +1,7 @@ IN: alien.arrays USING: help.syntax help.markup byte-arrays alien.c-types ; -ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" -"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:" -{ $subsection >c-bool-array } -{ $subsection >c-char-array } -{ $subsection >c-double-array } -{ $subsection >c-float-array } -{ $subsection >c-int-array } -{ $subsection >c-long-array } -{ $subsection >c-longlong-array } -{ $subsection >c-short-array } -{ $subsection >c-uchar-array } -{ $subsection >c-uint-array } -{ $subsection >c-ulong-array } -{ $subsection >c-ulonglong-array } -{ $subsection >c-ushort-array } -{ $subsection >c-void*-array } -{ $subsection c-bool-array> } -{ $subsection c-char-array> } -{ $subsection c-double-array> } -{ $subsection c-float-array> } -{ $subsection c-int-array> } -{ $subsection c-long-array> } -{ $subsection c-longlong-array> } -{ $subsection c-short-array> } -{ $subsection c-uchar-array> } -{ $subsection c-uint-array> } -{ $subsection c-ulong-array> } -{ $subsection c-ulonglong-array> } -{ $subsection c-ushort-array> } -{ $subsection c-void*-array> } ; - -ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays" -"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:" -{ $subsection char-nth } -{ $subsection set-char-nth } -{ $subsection uchar-nth } -{ $subsection set-uchar-nth } -{ $subsection short-nth } -{ $subsection set-short-nth } -{ $subsection ushort-nth } -{ $subsection set-ushort-nth } -{ $subsection int-nth } -{ $subsection set-int-nth } -{ $subsection uint-nth } -{ $subsection set-uint-nth } -{ $subsection long-nth } -{ $subsection set-long-nth } -{ $subsection ulong-nth } -{ $subsection set-ulong-nth } -{ $subsection longlong-nth } -{ $subsection set-longlong-nth } -{ $subsection ulonglong-nth } -{ $subsection set-ulonglong-nth } -{ $subsection float-nth } -{ $subsection set-float-nth } -{ $subsection double-nth } -{ $subsection set-double-nth } -{ $subsection void*-nth } -{ $subsection set-void*-nth } ; - ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." $nl -"C type specifiers for array types are documented in " { $link "c-types-specs" } "." -{ $subsection "c-arrays-factor" } -{ $subsection "c-arrays-get/set" } ; +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ; diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 94472e8261..727492edb1 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -8,6 +8,8 @@ UNION: value-type array struct-type ; M: array c-type ; +M: array c-type-class drop object ; + M: array heap-size unclip heap-size [ * ] reduce ; M: array c-type-align first c-type-align ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 739b45486f..a2b555b057 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -89,16 +89,6 @@ 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." } ; -HELP: define-nth -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } -{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - -HELP: define-set-nth -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } -{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - 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." } @@ -115,12 +105,12 @@ HELP: unbox-return { $notes "This is an internal word used by the compiler when compiling callbacks." } ; HELP: define-deref -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } +{ $values { "name" "a word name" } } { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; HELP: define-out -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } +{ $values { "name" "a word name" } } { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; @@ -230,9 +220,7 @@ $nl "You can copy a range of bytes from memory into a byte array:" { $subsection memory>byte-array } "You can copy a byte array to memory unsafely:" -{ $subsection byte-array>memory } -"A wrapper for temporarily allocating a block of memory:" -{ $subsection with-malloc } ; +{ $subsection byte-array>memory } ; ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index edda9e7fdb..f57d102452 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -55,4 +55,6 @@ TYPEDEF: uchar* MyLPBYTE 0 B{ 1 2 3 4 } ] must-fail -[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test +os windows? cpu x86.64? and [ + [ -2147467259 ] [ 2147500037 *long ] unit-test +] when diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 543af8dee8..c3ae644b47 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations ; +accessors combinators effects continuations fry ; IN: alien.c-types DEFER: @@ -13,13 +13,15 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type +class boxer boxer-quot unboxer unboxer-quot getter setter reg-class size align stack-align? ; : new-c-type ( class -- type ) new - int-regs >>reg-class ; + int-regs >>reg-class + object >>class ; inline : ( -- type ) \ c-type new-c-type ; @@ -50,7 +52,7 @@ GENERIC: c-type ( name -- type ) foldable : parse-array-type ( name -- array ) "[" split unclip - >r [ "]" ?tail drop string>number ] map r> prefix ; + [ [ "]" ?tail drop string>number ] map ] dip prefix ; M: string c-type ( name -- type ) CHAR: ] over member? [ @@ -63,6 +65,12 @@ M: string c-type ( name -- type ) ] ?if ] if ; +GENERIC: c-type-class ( name -- class ) + +M: c-type c-type-class class>> ; + +M: string c-type-class c-type c-type-class ; + GENERIC: c-type-boxer ( name -- boxer ) M: c-type c-type-boxer boxer>> ; @@ -172,12 +180,12 @@ M: byte-array byte-length length ; : c-getter ( name -- quot ) c-type-getter [ - [ "Cannot read struct fields with type" throw ] + [ "Cannot read struct fields with this type" throw ] ] unless* ; : c-setter ( name -- quot ) c-type-setter [ - [ "Cannot write struct fields with type" throw ] + [ "Cannot write struct fields with this type" throw ] ] unless* ; : ( n type -- array ) @@ -193,36 +201,21 @@ M: byte-array byte-length length ; 1 swap malloc-array ; inline : malloc-byte-array ( byte-array -- alien ) - dup length dup malloc [ -rot memcpy ] keep ; + dup length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) - dup [ -rot memcpy ] keep ; + [ nip dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -: (define-nth) ( word type quot -- ) +: array-accessor ( type quot -- def ) [ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* - ] [ ] make define-inline ; - -: nth-word ( name vocab -- word ) - >r "-nth" append r> create ; - -: define-nth ( name vocab -- ) - dupd nth-word swap dup c-getter (define-nth) ; - -: set-nth-word ( name vocab -- word ) - >r "set-" swap "-nth" 3append r> create ; - -: define-set-nth ( name vocab -- ) - dupd set-nth-word swap dup c-setter (define-nth) ; + ] [ ] make ; : typedef ( old new -- ) c-types get set-at ; -: define-c-type ( type name vocab -- ) - >r tuck typedef r> [ define-nth ] 2keep define-set-nth ; - TUPLE: long-long-type < c-type ; : ( -- type ) @@ -240,62 +233,34 @@ M: long-long-type box-parameter ( n type -- ) M: long-long-type box-return ( type -- ) f swap box-parameter ; -: define-deref ( name vocab -- ) - >r dup CHAR: * prefix r> create - swap c-getter 0 prefix define-inline ; +: define-deref ( name -- ) + [ CHAR: * prefix "alien.c-types" create ] + [ c-getter 0 prefix ] bi + define-inline ; -: define-out ( name vocab -- ) - over [ tuck 0 ] over c-setter append swap - >r >r constructor-word r> r> prefix define-inline ; +: define-out ( name -- ) + [ "alien.c-types" constructor-word ] + [ dup c-setter '[ _ [ 0 @ ] keep ] ] + bi define-inline ; : c-bool> ( int -- ? ) zero? not ; -: >c-array ( seq type word -- byte-array ) - [ [ dup length ] dip ] dip - [ [ execute ] 2curry each-index ] 2keep drop ; inline - -: >c-array-quot ( type vocab -- quot ) - dupd set-nth-word [ >c-array ] 2curry ; - -: to-array-word ( name vocab -- word ) - >r ">c-" swap "-array" 3append r> create ; - -: define-to-array ( type vocab -- ) - [ to-array-word ] 2keep >c-array-quot - (( array -- byte-array )) define-declared ; - -: c-array>quot ( type vocab -- quot ) - [ - \ swap , - nth-word 1quotation , - [ curry map ] % - ] [ ] make ; - -: from-array-word ( name vocab -- word ) - >r "c-" swap "-array>" 3append r> create ; - -: define-from-array ( type vocab -- ) - [ from-array-word ] 2keep c-array>quot - (( c-ptr n -- array )) define-declared ; - : define-primitive-type ( type name -- ) - "alien.c-types" - { - [ define-c-type ] - [ define-deref ] - [ define-to-array ] - [ define-from-array ] - [ define-out ] - } 2cleave ; + [ typedef ] + [ define-deref ] + [ define-out ] + tri ; : expand-constants ( c-type -- c-type' ) dup array? [ - unclip >r [ - dup word? [ - def>> { } swap with-datastack first - ] when - ] map r> prefix + unclip [ + [ + dup word? [ + def>> { } swap with-datastack first + ] when + ] map + ] dip prefix ] when ; : malloc-file-contents ( path -- alien len ) @@ -304,8 +269,20 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: primitive-types + { + "char" "uchar" + "short" "ushort" + "int" "uint" + "long" "ulong" + "longlong" "ulonglong" + "float" "double" + "void*" "bool" + } ; + [ + c-ptr >>class [ alien-cell ] >>getter [ set-alien-cell ] >>setter bootstrap-cell >>size @@ -315,6 +292,7 @@ M: long-long-type box-return ( type -- ) "void*" define-primitive-type + integer >>class [ alien-signed-8 ] >>getter [ set-alien-signed-8 ] >>setter 8 >>size @@ -324,6 +302,7 @@ M: long-long-type box-return ( type -- ) "longlong" define-primitive-type + integer >>class [ alien-unsigned-8 ] >>getter [ set-alien-unsigned-8 ] >>setter 8 >>size @@ -333,6 +312,7 @@ M: long-long-type box-return ( type -- ) "ulonglong" define-primitive-type + integer >>class [ alien-signed-cell ] >>getter [ set-alien-signed-cell ] >>setter bootstrap-cell >>size @@ -342,6 +322,7 @@ M: long-long-type box-return ( type -- ) "long" define-primitive-type + integer >>class [ alien-unsigned-cell ] >>getter [ set-alien-unsigned-cell ] >>setter bootstrap-cell >>size @@ -351,6 +332,7 @@ M: long-long-type box-return ( type -- ) "ulong" define-primitive-type + integer >>class [ alien-signed-4 ] >>getter [ set-alien-signed-4 ] >>setter 4 >>size @@ -360,6 +342,7 @@ M: long-long-type box-return ( type -- ) "int" define-primitive-type + integer >>class [ alien-unsigned-4 ] >>getter [ set-alien-unsigned-4 ] >>setter 4 >>size @@ -369,6 +352,7 @@ M: long-long-type box-return ( type -- ) "uint" define-primitive-type + fixnum >>class [ alien-signed-2 ] >>getter [ set-alien-signed-2 ] >>setter 2 >>size @@ -378,6 +362,7 @@ M: long-long-type box-return ( type -- ) "short" define-primitive-type + fixnum >>class [ alien-unsigned-2 ] >>getter [ set-alien-unsigned-2 ] >>setter 2 >>size @@ -387,6 +372,7 @@ M: long-long-type box-return ( type -- ) "ushort" define-primitive-type + fixnum >>class [ alien-signed-1 ] >>getter [ set-alien-signed-1 ] >>setter 1 >>size @@ -396,6 +382,7 @@ M: long-long-type box-return ( type -- ) "char" define-primitive-type + fixnum >>class [ alien-unsigned-1 ] >>getter [ set-alien-unsigned-1 ] >>setter 1 >>size @@ -414,6 +401,7 @@ M: long-long-type box-return ( type -- ) "bool" define-primitive-type + float >>class [ alien-float ] >>getter [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size @@ -425,6 +413,7 @@ M: long-long-type box-return ( type -- ) "float" define-primitive-type + float >>class [ alien-double ] >>getter [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor new file mode 100644 index 0000000000..193893fabc --- /dev/null +++ b/basis/alien/parser/parser.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays assocs effects grouping kernel +parser sequences splitting words fry locals ; +IN: alien.parser + +: parse-arglist ( parameters return -- types effect ) + [ 2 group unzip [ "," ?tail drop ] map ] + [ [ { } ] [ 1array ] if-void ] + bi* ; + +: function-quot ( return library function types -- quot ) + '[ _ _ _ _ alien-invoke ] ; + +:: define-function ( return library function parameters -- ) + function create-in dup reset-generic + return library function + parameters return parse-arglist [ function-quot ] dip + define-declared ; diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor index 70bbe773ee..d482634772 100644 --- a/basis/alien/strings/strings.factor +++ b/basis/alien/strings/strings.factor @@ -3,13 +3,13 @@ USING: arrays sequences kernel accessors math alien.accessors alien.c-types byte-arrays words io io.encodings io.streams.byte-array io.streams.memory io.encodings.utf8 -io.encodings.utf16 system alien strings cpu.architecture ; +io.encodings.utf16 system alien strings cpu.architecture fry ; IN: alien.strings GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) M: c-ptr alien>string - >r r> + [ ] [ ] bi* "\0" swap stream-read-until drop ; M: f alien>string @@ -40,6 +40,9 @@ PREDICATE: string-type < pair M: string-type c-type ; +M: string-type c-type-class + drop object ; + M: string-type heap-size drop "void*" heap-size ; @@ -74,10 +77,10 @@ M: string-type c-type-unboxer drop "void*" c-type-unboxer ; M: string-type c-type-boxer-quot - second [ alien>string ] curry [ ] like ; + second '[ _ alien>string ] ; M: string-type c-type-unboxer-quot - second [ string>alien ] curry [ ] like ; + second '[ _ string>alien ] ; M: string-type c-type-getter drop [ alien-cell ] ; diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 19e5b8c326..abce91f56f 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -29,10 +29,10 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; writer>> swap "writing" set-word-prop ; : reader-word ( class name vocab -- word ) - >r >r "-" r> 3append r> create ; + [ "-" glue ] dip create ; : writer-word ( class name vocab -- word ) - >r [ swap "set-" % % "-" % % ] "" make r> create ; + [ [ swap "set-" % % "-" % % ] "" make ] dip create ; : ( struct-name vocab type field-name -- spec ) field-spec new @@ -52,25 +52,21 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; [ (>>offset) ] [ type>> heap-size + ] 2bi ] reduce ; -: define-struct-slot-word ( spec word quot -- ) - rot offset>> prefix define-inline ; +: define-struct-slot-word ( word quot spec -- ) + offset>> prefix define-inline ; : define-getter ( type spec -- ) [ set-reader-props ] keep - [ ] [ reader>> ] [ type>> [ c-getter ] [ c-type-boxer-quot ] bi append - ] tri - define-struct-slot-word ; + ] + [ ] tri define-struct-slot-word ; : define-setter ( type spec -- ) [ set-writer-props ] keep - [ ] - [ writer>> ] - [ type>> c-setter ] tri - define-struct-slot-word ; + [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ; : define-field ( type spec -- ) [ define-getter ] [ define-setter ] 2bi ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index 8c7d9f9b29..ec0c01c2e7 100644 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -38,7 +38,7 @@ C-UNION: barx [ 120 ] [ "barx" heap-size ] unit-test "help" vocab [ - "help" "help" lookup "help" set + "print-topic" "help" lookup "help" set [ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test ] when diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index adb25aa977..a3c616cda2 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -9,6 +9,8 @@ TUPLE: struct-type size align fields ; M: struct-type heap-size size>> ; +M: struct-type c-type-class drop object ; + M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; @@ -36,25 +38,26 @@ M: struct-type stack-size : c-struct? ( type -- ? ) (c-type) struct-type? ; -: (define-struct) ( name vocab size align fields -- ) - >r [ align ] keep r> +: (define-struct) ( name size align fields -- ) + [ [ align ] keep ] dip struct-type boa - -rot define-c-type ; + swap typedef ; -: define-struct-early ( name vocab fields -- fields ) +: make-fields ( name vocab fields -- fields ) [ first2 ] with with map ; : compute-struct-align ( types -- n ) [ c-type-align ] map supremum ; : define-struct ( name vocab fields -- ) - pick >r - [ struct-offsets ] keep - [ [ type>> ] map compute-struct-align ] keep - [ (define-struct) ] keep - r> [ swap define-field ] curry each ; + [ + [ 2drop ] [ make-fields ] 3bi + [ struct-offsets ] keep + [ [ type>> ] map compute-struct-align ] keep + [ (define-struct) ] keep + ] [ 2drop '[ _ swap define-field ] ] 3bi each ; -: define-union ( name vocab members -- ) +: define-union ( name members -- ) [ expand-constants ] map [ [ heap-size ] map supremum ] keep compute-struct-align f (define-struct) ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 37cbd12801..586bb97402 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -1,5 +1,5 @@ IN: alien.syntax -USING: alien alien.c-types alien.structs alien.syntax.private +USING: alien alien.c-types alien.parser alien.structs help.markup help.syntax ; HELP: DLL" @@ -54,12 +54,6 @@ HELP: TYPEDEF: { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." } { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; -HELP: TYPEDEF-IF: -{ $syntax "TYPEDEF-IF: word old new" } -{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } } -{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." } -{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; - HELP: C-STRUCT: { $syntax "C-STRUCT: name pairs... ;" } { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } } @@ -88,7 +82,7 @@ HELP: typedef { $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ; -{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words +{ POSTPONE: TYPEDEF: typedef } related-words HELP: c-struct? { $values { "type" "a string" } { "?" "a boolean" } } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 7629897fc0..d10c97cd3d 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -4,35 +4,9 @@ USING: accessors arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects prettyprint prettyprint.sections prettyprint.backend -assocs combinators lexer strings.parser ; +assocs combinators lexer strings.parser alien.parser ; IN: alien.syntax - ; - -: function-quot ( type lib func types -- quot ) - [ alien-invoke ] 2curry 2curry ; - -: define-function ( return library function parameters -- ) - >r pick r> parse-arglist - pick create-in dup reset-generic - >r >r function-quot r> r> - -rot define-declared ; - -PRIVATE> - -: indirect-quot ( function-ptr-quot return types abi -- quot ) - [ alien-indirect ] 3curry compose ; - -: define-indirect ( abi return function-ptr-quot function-name parameters -- ) - >r pick r> parse-arglist - rot create-in dup reset-generic - >r >r swapd roll indirect-quot r> r> - -rot define-declared ; - : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing : ALIEN: scan string>number parsed ; parsing @@ -49,22 +23,16 @@ PRIVATE> : TYPEDEF: scan scan typedef ; parsing -: TYPEDEF-IF: - scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing - : C-STRUCT: - scan in get - parse-definition - >r 2dup r> define-struct-early - define-struct ; parsing + scan in get parse-definition define-struct ; parsing : C-UNION: - scan in get parse-definition define-union ; parsing + scan parse-definition define-union ; parsing : C-ENUM: ";" parse-tokens dup length - [ >r create-in r> 1quotation define ] 2each ; + [ [ create-in ] dip 1quotation define ] 2each ; parsing M: alien pprint* diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 11601f7b63..4cb2032f4f 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel kernel.private locals sequences sequences.private byte-arrays -parser prettyprint.backend ; +parser prettyprint.backend fry ; IN: bit-arrays TUPLE: bit-array @@ -24,9 +24,8 @@ TUPLE: bit-array : bits>bytes 7 + n>byte ; inline : (set-bits) ( bit-array n -- ) - [ [ length bits>cells ] keep ] dip - [ -rot underlying>> set-uint-nth ] 2curry - each ; inline + [ [ length bits>cells ] keep ] dip swap underlying>> + '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline PRIVATE> @@ -84,9 +83,9 @@ M: bit-array byte-length length 7 + -3 shift ; ] if ; : bit-array>integer ( bit-array -- n ) - 0 swap underlying>> [ length ] keep [ - uchar-nth swap 8 shift bitor - ] curry each ; + 0 swap underlying>> dup length [ + alien-unsigned-1 swap 8 shift bitor + ] with each ; INSTANCE: bit-array sequence diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index dff9a8db37..31327999e7 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -4,7 +4,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ; [ 0 ] [ 123 length ] unit-test : do-it - 1234 swap [ >r even? r> push ] curry each ; + 1234 swap [ [ even? ] dip push ] curry each ; [ t ] [ 3 dup do-it diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index dabdeea741..9968af4330 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -60,7 +60,7 @@ nl "." write flush { - new-sequence nth push pop peek + new-sequence nth push pop peek flip } compile-uncompiled "." write flush diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index d5f36db776..380c9b2348 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -72,7 +72,7 @@ SYMBOL: objects : put-object ( n obj -- ) (objects) set-at ; : cache-object ( obj quot -- value ) - >r (objects) r> [ obj>> ] prepose cache ; inline + [ (objects) ] dip [ obj>> ] prepose cache ; inline ! Constants @@ -97,10 +97,10 @@ SYMBOL: sub-primitives { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline : jit-define ( quot rc rt offset name -- ) - >r make-jit r> set ; inline + [ make-jit ] dip set ; inline : define-sub-primitive ( quot rc rt offset word -- ) - >r make-jit r> sub-primitives get set-at ; + [ make-jit ] dip sub-primitives get set-at ; ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -124,10 +124,10 @@ SYMBOL: jit-primitive-word SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call -SYMBOL: jit-push-literal SYMBOL: jit-push-immediate SYMBOL: jit-if-word -SYMBOL: jit-if-jump +SYMBOL: jit-if-1 +SYMBOL: jit-if-2 SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch SYMBOL: jit-dip-word @@ -155,9 +155,9 @@ SYMBOL: undefined-quot { jit-primitive 25 } { jit-word-jump 26 } { jit-word-call 27 } - { jit-push-literal 28 } - { jit-if-word 29 } - { jit-if-jump 30 } + { jit-if-word 28 } + { jit-if-1 29 } + { jit-if-2 30 } { jit-dispatch-word 31 } { jit-dispatch 32 } { jit-epilog 33 } @@ -205,7 +205,7 @@ SYMBOL: undefined-quot : emit-fixnum ( n -- ) tag-fixnum emit ; : emit-object ( header tag quot -- addr ) - swap here-as >r swap tag-fixnum emit call align-here r> ; + swap here-as [ swap tag-fixnum emit call align-here ] dip ; inline ! Write an object to the image. @@ -351,7 +351,12 @@ M: wrapper ' : pad-bytes ( seq -- newseq ) dup length bootstrap-cell align 0 pad-right ; +: check-string ( string -- ) + [ 127 > ] contains? + [ "Bootstrap cannot emit non-ASCII strings" throw ] when ; + : emit-string ( string -- ptr ) + dup check-string string type-number object tag-number [ dup length emit-fixnum f ' emit @@ -469,10 +474,10 @@ M: quotation ' jit-primitive jit-word-jump jit-word-call - jit-push-literal jit-push-immediate jit-if-word - jit-if-jump + jit-if-1 + jit-if-2 jit-dispatch-word jit-dispatch jit-dip-word diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index ac8e5343e1..4ab36ec94e 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -32,8 +32,8 @@ SYMBOL: bootstrap-time : count-words ( pred -- ) all-words swap count number>string write ; -: print-time ( us -- ) - 1000000 /i +: print-time ( ms -- ) + 1000 /i 60 /mod swap number>string write " minutes and " write number>string write " seconds." print ; @@ -52,16 +52,16 @@ SYMBOL: bootstrap-time [ ! We time bootstrap - micros + millis default-image-name "output-image" set-global "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global - parse-command-line + (command-line) parse-command-line - "-no-crossref" cli-args member? [ do-crossref ] unless + do-crossref ! Set dll paths os wince? [ "windows.ce" require ] when @@ -77,7 +77,7 @@ SYMBOL: bootstrap-time [ load-components - micros over - core-bootstrap-time set-global + millis over - core-bootstrap-time set-global run-bootstrap-init ] with-compiler-errors @@ -92,15 +92,10 @@ SYMBOL: bootstrap-time [ boot do-init-hooks - [ - parse-command-line - run-user-init - "run" get run - output-stream get [ stream-flush ] when* - ] [ print-error 1 exit ] recover + handle-command-line ] set-boot-quot - micros swap - bootstrap-time set-global + millis swap - bootstrap-time set-global print-report "output-image" get save-image-and-exit diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 9e2e8a4673..39f8eb44cc 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -23,4 +23,4 @@ ERROR: box-empty box ; dup occupied>> [ box> t ] [ drop f f ] if ; : if-box? ( box quot -- ) - >r ?box r> [ drop ] if ; inline + [ ?box ] dip [ drop ] if ; inline diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 433459cb24..748f9d124c 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -99,6 +99,48 @@ HELP: seconds-per-year { $values { "integer" integer } } { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ; +HELP: biweekly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of two week periods in a year." } ; + +HELP: daily-360 +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of days in a 360-day year." } ; + +HELP: daily-365 +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of days in a 365-day year." } ; + +HELP: monthly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of months in a year." } ; + +HELP: semimonthly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ; + +HELP: weekly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of weeks in a year." } ; + HELP: julian-day-number { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } } { $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } @@ -540,6 +582,8 @@ ARTICLE: "calendar" "Calendar" { $subsection "years" } { $subsection "months" } { $subsection "days" } +"Calculating amounts per period of time:" +{ $subsection "time-period-calculations" } "Meta-data about the calendar:" { $subsection "calendar-facts" } ; @@ -626,6 +670,18 @@ ARTICLE: "calendar-facts" "Calendar facts" { $subsection day-of-week } ; +ARTICLE: "time-period-calculations" "Calculations over periods of time" +{ $subsection monthly } +{ $subsection semimonthly } +{ $subsection biweekly } +{ $subsection weekly } +{ $subsection daily-360 } +{ $subsection daily-365 } +{ $subsection biweekly } +{ $subsection biweekly } +{ $subsection biweekly } +; + ARTICLE: "years" "Year operations" "Leap year predicate:" { $subsection leap-year? } diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 00d5730745..943ba8c3d5 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -167,3 +167,5 @@ IN: calendar.tests [ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test + +[ 4+1/6 ] [ 100 semimonthly ] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index a78cf60eb0..e2564b5a28 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -89,6 +89,13 @@ PRIVATE> : minutes-per-year ( -- ratio ) 5259492/10 ; inline : seconds-per-year ( -- integer ) 31556952 ; inline +: monthly ( x -- y ) 12 / ; inline +: semimonthly ( x -- y ) 24 / ; inline +: biweekly ( x -- y ) 26 / ; inline +: weekly ( x -- y ) 52 / ; inline +: daily-360 ( x -- y ) 360 / ; inline +: daily-365 ( x -- y ) 365 / ; inline + :: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 @@ -173,7 +180,7 @@ M: real +year ( timestamp n -- timestamp ) 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline M: integer +month ( timestamp n -- timestamp ) - [ over month>> + months/years >r >>month r> +year ] unless-zero ; + [ over month>> + months/years [ >>month ] dip +year ] unless-zero ; M: real +month ( timestamp n -- timestamp ) [ float>whole-part swapd average-month * +day swap +month ] unless-zero ; @@ -181,7 +188,7 @@ M: real +month ( timestamp n -- timestamp ) M: integer +day ( timestamp n -- timestamp ) [ over >date< julian-day-number + julian-day-number>date - >r >r >>year r> >>month r> >>day + [ >>year ] [ >>month ] [ >>day ] tri* ] unless-zero ; M: real +day ( timestamp n -- timestamp ) @@ -191,7 +198,7 @@ M: real +day ( timestamp n -- timestamp ) 24 /rem swap ; M: integer +hour ( timestamp n -- timestamp ) - [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ; + [ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ; M: real +hour ( timestamp n -- timestamp ) float>whole-part swapd 60 * +minute swap +hour ; @@ -200,7 +207,7 @@ M: real +hour ( timestamp n -- timestamp ) 60 /rem swap ; M: integer +minute ( timestamp n -- timestamp ) - [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ; + [ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ; M: real +minute ( timestamp n -- timestamp ) [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; @@ -209,7 +216,7 @@ M: real +minute ( timestamp n -- timestamp ) 60 /rem swap >integer ; M: number +second ( timestamp n -- timestamp ) - [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ; + [ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ; : (time+) [ second>> +second ] keep @@ -226,7 +233,7 @@ PRIVATE> GENERIC# time+ 1 ( time1 time2 -- time3 ) M: timestamp time+ - >r clone r> (time+) drop ; + [ clone ] dip (time+) drop ; M: duration time+ dup timestamp? [ @@ -284,7 +291,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) : (time-) ( timestamp timestamp -- n ) [ >gmt ] bi@ [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep - [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ; + [ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ; M: timestamp time- #! Exact calendar-time difference @@ -320,13 +327,13 @@ M: duration time- 1970 1 1 0 0 0 instant ; : millis>timestamp ( x -- timestamp ) - >r unix-1970 r> milliseconds time+ ; + [ unix-1970 ] dip milliseconds time+ ; : timestamp>millis ( timestamp -- n ) unix-1970 (time-) 1000 * >integer ; : micros>timestamp ( x -- timestamp ) - >r unix-1970 r> microseconds time+ ; + [ unix-1970 ] dip microseconds time+ ; : timestamp>micros ( timestamp -- n ) unix-1970 (time-) 1000000 * >integer ; @@ -343,10 +350,11 @@ M: duration time- #! Zeller Congruence #! http://web.textfiles.com/computers/formulas.txt #! good for any date since October 15, 1582 - >r dup 2 <= [ 12 + >r 1- r> ] when - >r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r> - [ 1+ 3 * 5 /i + ] keep 2 * + r> - 1+ + 7 mod ; + [ + dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when + [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip + [ 1+ 3 * 5 /i + ] keep 2 * + + ] dip 1+ + 7 mod ; GENERIC: days-in-year ( obj -- n ) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index b15da42409..8d34e8a3a4 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -138,11 +138,11 @@ M: timestamp year. ( timestamp -- ) : read-rfc3339-gmt-offset ( ch -- dt ) dup CHAR: Z = [ drop instant ] [ - >r - read-00 hours - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes - time+ - r> signed-gmt-offset + [ + read-00 hours + read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes + time+ + ] dip signed-gmt-offset ] if ; : read-ymd ( -- y m d ) @@ -152,8 +152,9 @@ M: timestamp year. ( timestamp -- ) read-00 ":" expect read-00 ":" expect read-00 ; : read-rfc3339-seconds ( s -- s' ch ) - "+-Z" read-until >r - [ string>number ] [ length 10 swap ^ ] bi / + r> ; + "+-Z" read-until [ + [ string>number ] [ length 10 swap ^ ] bi / + + ] dip ; : (rfc3339>timestamp) ( -- timestamp ) read-ymd @@ -181,9 +182,9 @@ ERROR: invalid-timestamp-format ; : parse-rfc822-gmt-offset ( string -- dt ) dup "GMT" = [ drop instant ] [ - unclip >r - 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+ - r> signed-gmt-offset + unclip [ + 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+ + ] dip signed-gmt-offset ] if ; : (rfc822>timestamp) ( -- timestamp ) diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index 1a7addac12..6e10b23407 100644 --- a/basis/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -14,7 +14,7 @@ IN: channels.remote PRIVATE> : publish ( channel -- id ) - 256 random-bits dup >r remote-channels set-at r> ; + 256 random-bits dup [ remote-channels set-at ] dip ; : get-channel ( id -- channel ) remote-channels at ; diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 1f25efef24..7d5f34777d 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -18,4 +18,4 @@ SYMBOL: bytes-read ] "" make 64 group ; : update-old-new ( old new -- ) - [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline + [ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 6158254f84..257fd930c4 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,7 +14,7 @@ IN: checksums.md5 SYMBOLS: a b c d old-a old-b old-c old-d ; : T ( N -- Y ) - sin abs 4294967296 * >bignum ; foldable + sin abs 4294967296 * >integer ; foldable : initialize-md5 ( -- ) 0 bytes-read set diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index d42febb541..821cbe2f3a 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -28,7 +28,7 @@ M: evp-md-context dispose handle>> EVP_MD_CTX_cleanup drop ; : with-evp-md-context ( quot -- ) - maybe-init-ssl >r r> with-disposal ; inline + maybe-init-ssl [ ] dip with-disposal ; inline : digest-named ( name -- md ) dup EVP_get_digestbyname diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor index bbae421b16..3767af7c55 100644 --- a/basis/checksums/sha1/sha1.factor +++ b/basis/checksums/sha1/sha1.factor @@ -41,9 +41,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : sha1-f ( B C D t -- f_tbcd ) 20 /i { - { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] } + { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] } { 1 [ bitxor bitxor ] } - { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } + { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] } { 3 [ bitxor bitxor ] } } case ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 0a6d8c26ab..beb657bd3e 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -59,7 +59,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; [ 15 - swap nth s0-256 ] 2keep [ 7 - swap nth ] 2keep [ 2 - swap nth s1-256 ] 2keep - >r >r + + w+ r> r> swap set-nth ; inline + [ + + w+ ] 2dip swap set-nth ; inline : prepare-message-schedule ( seq -- w-seq ) word-size get group [ be> ] map block-size get 0 pad-right @@ -71,7 +71,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; [ bitxor bitand ] keep bitxor ; : maj ( x y z -- x' ) - >r [ bitand ] 2keep bitor r> bitand bitor ; + [ [ bitand ] 2keep bitor ] dip bitand bitor ; : S0-256 ( x -- x' ) [ -2 bitroll-32 ] keep @@ -83,7 +83,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; [ -11 bitroll-32 ] keep -25 bitroll-32 bitxor bitxor ; inline -: slice3 ( n seq -- a b c ) >r dup 3 + r> first3 ; inline +: slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline : T1 ( W n -- T1 ) [ swap nth ] keep @@ -105,7 +105,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; d c pick exchange c b pick exchange b a pick exchange - >r w+ a r> set-nth ; + [ w+ a ] dip set-nth ; : process-chunk ( M -- ) H get clone vars set @@ -118,7 +118,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; : preprocess-plaintext ( string big-endian? -- padded-string ) #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - >r >sbuf r> over [ + [ >sbuf ] dip over [ HEX: 80 , dup length HEX: 3f bitand calculate-pad-length 0 % diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 8f32782d76..ab12a93a31 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -27,35 +27,31 @@ IN: cocoa.application : NSApp ( -- app ) NSApplication -> sharedApplication ; +: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline + FUNCTION: void NSBeep ( ) ; : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; inline : next-event ( app -- event ) - 0 f CFRunLoopDefaultMode 1 + NSAnyEventMask f CFRunLoopDefaultMode 1 -> nextEventMatchingMask:untilDate:inMode:dequeue: ; : do-event ( app -- ? ) - dup next-event [ -> sendEvent: t ] [ drop f ] if* ; + dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ; : add-observer ( observer selector name object -- ) - >r >r >r >r NSNotificationCenter -> defaultCenter - r> r> sel_registerName - r> r> -> addObserver:selector:name:object: ; + [ + [ NSNotificationCenter -> defaultCenter ] 2dip + sel_registerName + ] 2dip -> addObserver:selector:name:object: ; : remove-observer ( observer -- ) - >r NSNotificationCenter -> defaultCenter r> + [ NSNotificationCenter -> defaultCenter ] dip -> removeObserver: ; -: finish-launching ( -- ) NSApp -> finishLaunching ; - -: cocoa-app ( quot -- ) - [ - call - finish-launching - NSApp -> run - ] with-cocoa ; inline +: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline : install-delegate ( receiver delegate -- ) -> alloc -> init -> setDelegate: ; @@ -80,6 +76,6 @@ M: objc-error summary ( error -- ) running.app? [ drop ] [ - "The " swap " requires you to run Factor from an application bundle." - 3append throw + "The " " requires you to run Factor from an application bundle." + surround throw ] if ; diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index e1d6672872..59ea91c3cf 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,7 +1,7 @@ IN: cocoa.tests USING: cocoa cocoa.messages cocoa.subclassing cocoa.types compiler kernel namespaces cocoa.classes tools.test memory -compiler.units ; +compiler.units math ; CLASS: { { +superclass+ "NSObject" } @@ -45,3 +45,27 @@ Bar [ [ 2.0 ] [ "x" get NSRect-y ] unit-test [ 101.0 ] [ "x" get NSRect-w ] unit-test [ 102.0 ] [ "x" get NSRect-h ] unit-test + +! Make sure that we can add methods +CLASS: { + { +superclass+ "NSObject" } + { +name+ "Bar" } +} { + "bar" + "NSRect" + { "id" "SEL" } + [ 2drop test-foo "x" get ] +} { + "babb" + "int" + { "id" "SEL" "int" } + [ 2nip sq ] +} ; + +[ 144 ] [ + Bar [ + -> alloc -> init + dup 12 -> babb + swap -> release + ] compile-call +] unit-test diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 662b4a7bae..2b01c5d751 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel cocoa cocoa.messages cocoa.classes cocoa.application sequences splitting core-foundation ; @@ -29,6 +29,6 @@ IN: cocoa.dialogs "/" split1-last [ ] bi@ ; : save-panel ( path -- paths ) - dup - rot split-path -> runModalForDirectory:file: NSOKButton = + [ dup ] dip + split-path -> runModalForDirectory:file: NSOKButton = [ -> filename CF>string ] [ drop f ] if ; diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index 7de1f24a3c..7f5b777283 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,26 +1,31 @@ -USING: kernel cocoa cocoa.types alien.c-types locals math sequences -vectors fry libc ; +! 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 ; IN: cocoa.enumeration : NS-EACH-BUFFER-SIZE 16 ; inline -: (with-enumeration-buffers) ( quot -- ) - "NSFastEnumerationState" heap-size swap '[ - NS-EACH-BUFFER-SIZE "id" heap-size * [ - NS-EACH-BUFFER-SIZE @ - ] with-malloc - ] with-malloc ; inline +: with-enumeration-buffers ( quot -- ) + [ + [ + "NSFastEnumerationState" malloc-object &free + NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free + NS-EACH-BUFFER-SIZE + ] dip call + ] with-destructors ; inline :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) object state stackbuf count -> countByEnumeratingWithState:objects:count: - dup zero? [ drop ] [ + dup 0 = [ drop ] [ state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* - '[ _ void*-nth quot call ] each + swap quot each object quot state stackbuf count (NSFastEnumeration-each) ] if ; inline recursive : NSFastEnumeration-each ( object quot -- ) - [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline + [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline : NSFastEnumeration-map ( object quot -- vector ) NS-EACH-BUFFER-SIZE diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 09b2255913..e33217a691 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -combinators compiler compiler.alien kernel math namespaces make -parser prettyprint prettyprint.sections quotations sequences -strings words cocoa.runtime io macros memoize debugger -io.encodings.ascii effects libc libc.private parser lexer init -core-foundation fry ; +continuations combinators compiler compiler.alien kernel math +namespaces make parser prettyprint prettyprint.sections +quotations sequences strings words cocoa.runtime io macros +memoize debugger io.encodings.ascii effects libc libc.private +parser lexer init core-foundation fry generalizations +specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -27,7 +28,7 @@ super-message-senders global [ H{ } assoc-like ] change-at : cache-stub ( method function hash -- ) [ - over get [ 2drop ] [ over >r sender-stub r> set ] if + over get [ 2drop ] [ over [ sender-stub ] dip set ] if ] bind ; : cache-stubs ( method -- ) @@ -37,7 +38,7 @@ super-message-senders global [ H{ } assoc-like ] change-at : ( receiver -- super ) "objc-super" [ - >r dup object_getClass class_getSuperclass r> + [ dup object_getClass class_getSuperclass ] dip set-objc-super-class ] keep [ set-objc-super-receiver ] keep ; @@ -62,23 +63,18 @@ objc-methods global [ H{ } assoc-like ] change-at dup objc-methods get at [ ] [ "No such method: " prepend throw ] ?if ; -: make-dip ( quot n -- quot' ) - dup - \ >r >quotation -rot - \ r> >quotation 3append ; - MEMO: make-prepare-send ( selector method super? -- quot ) [ [ \ , ] when swap , \ selector , ] [ ] make - swap second length 2 - make-dip ; + swap second length 2 - '[ _ _ ndip ] ; MACRO: (send) ( selector super? -- quot ) - >r dup lookup-method r> + [ dup lookup-method ] dip [ make-prepare-send ] 2keep super-message-senders message-senders ? get at - [ slip execute ] 2curry ; + '[ _ call _ execute ] ; : send ( receiver args... selector -- return... ) f (send) ; inline @@ -89,9 +85,17 @@ MACRO: (send) ( selector super? -- quot ) \ super-send soft "break-after" set-word-prop ! Runtime introspection -: (objc-class) ( string word -- class ) - dupd execute - [ ] [ "No such class: " prepend throw ] ?if ; inline +SYMBOL: class-init-hooks + +class-init-hooks global [ H{ } clone or ] change-at + +: (objc-class) ( name word -- class ) + 2dup execute dup [ 2nip ] [ + drop over class-init-hooks get at [ assert-depth ] when* + 2dup execute dup [ 2nip ] [ + 2drop "No such class: " prepend throw + ] if + ] if ; inline : objc-class ( string -- class ) \ objc_getClass (objc-class) ; @@ -165,14 +169,14 @@ objc>alien-types get [ swap ] assoc-map assoc-union alien>objc-types set-global : objc-struct-type ( i string -- ctype ) - 2dup CHAR: = -rot index-from swap subseq + [ CHAR: = ] 2keep index-from swap subseq dup c-types get key? [ "Warning: no such C type: " write dup print drop "void*" ] unless ; : (parse-objc-type) ( i string -- ctype ) - 2dup nth >r >r 1+ r> r> { + [ [ 1+ ] dip ] [ nth ] 2bi { { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] } { [ dup CHAR: ^ = ] [ 3drop "void*" ] } { [ dup CHAR: { = ] [ drop objc-struct-type ] } @@ -203,8 +207,11 @@ assoc-union alien>objc-types set-global objc-methods get set-at ; : each-method-in-class ( class quot -- ) - [ 0 [ class_copyMethodList ] keep *uint over ] dip - '[ _ void*-nth @ ] each (free) ; inline + [ 0 [ class_copyMethodList ] keep *uint ] dip + over 0 = [ 3drop ] [ + [ ] dip + [ each ] [ drop underlying>> (free) ] 2bi + ] if ; inline : register-objc-methods ( class -- ) [ register-objc-method ] each-method-in-class ; @@ -222,23 +229,20 @@ assoc-union alien>objc-types set-global : class-exists? ( string -- class ) objc_getClass >boolean ; -: unless-defined ( class quot -- ) - >r class-exists? r> unless ; inline - -: define-objc-class-word ( name quot -- ) +: define-objc-class-word ( quot name -- ) + [ class-init-hooks get set-at ] [ - over , , \ unless-defined , dup , \ objc-class , - ] [ ] make >r "cocoa.classes" create r> - (( -- class )) define-declared ; + [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi + (( -- class )) define-declared + ] bi ; : import-objc-class ( name quot -- ) - 2dup unless-defined - dupd define-objc-class-word - [ - dup - objc-class register-objc-methods - objc-meta-class register-objc-methods - ] curry try ; + over define-objc-class-word + '[ + _ + [ objc-class register-objc-methods ] + [ objc-meta-class register-objc-methods ] bi + ] try ; : root-class ( class -- root ) dup class_getSuperclass [ root-class ] [ ] ?if ; diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor index d266c2452f..b530ccbc37 100644 --- a/basis/cocoa/pasteboard/pasteboard.factor +++ b/basis/cocoa/pasteboard/pasteboard.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays kernel cocoa.messages -cocoa.classes cocoa.application cocoa core-foundation -sequences ; +USING: alien.accessors arrays kernel cocoa.messages +cocoa.classes cocoa.application cocoa core-foundation sequences +; IN: cocoa.pasteboard : NSStringPboardType "NSStringPboardType" ; @@ -20,11 +20,11 @@ IN: cocoa.pasteboard : set-pasteboard-string ( str pasteboard -- ) NSStringPboardType dup 1array pick set-pasteboard-types - >r swap r> -> setString:forType: drop ; + [ swap ] dip -> setString:forType: drop ; : pasteboard-error ( error -- f ) "Pasteboard does not hold a string" - 0 spin set-void*-nth f ; + 0 set-alien-cell f ; : ?pasteboard-string ( pboard error -- str/f ) over pasteboard-string? [ diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index fd18c7fa89..b49d55a30b 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2006, 2008 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays assocs combinators compiler hashtables kernel libc math namespaces -parser sequences words cocoa.messages cocoa.runtime -compiler.units io.encodings.ascii generalizations -continuations make ; +parser sequences words cocoa.messages cocoa.runtime locals +compiler.units io.encodings.ascii continuations make fry ; IN: cocoa.subclassing : init-method ( method -- sel imp types ) @@ -12,22 +11,25 @@ IN: cocoa.subclassing [ sel_registerName ] [ execute ] [ ascii string>alien ] tri* ; -: throw-if-false ( YES/NO -- ) - zero? [ "Failed to add method or protocol to class" throw ] - when ; +: throw-if-false ( obj what -- ) + swap { f 0 } member? + [ "Failed to " prepend throw ] [ drop ] if ; + +: add-method ( class sel imp types -- ) + class_addMethod "add method to class" throw-if-false ; : add-methods ( methods class -- ) - swap - [ init-method class_addMethod throw-if-false ] with each ; + '[ [ _ ] dip init-method add-method ] each ; + +: add-protocol ( class protocol -- ) + class_addProtocol "add protocol to class" throw-if-false ; : add-protocols ( protocols class -- ) - swap [ objc-protocol class_addProtocol throw-if-false ] - with each ; + '[ [ _ ] dip objc-protocol add-protocol ] each ; -: (define-objc-class) ( protocols superclass name imeth -- ) - -rot +: (define-objc-class) ( imeth protocols superclass name -- ) [ objc-class ] dip 0 objc_allocateClassPair - [ add-methods ] [ add-protocols ] [ objc_registerClassPair ] + [ add-protocols ] [ add-methods ] [ objc_registerClassPair ] tri ; : encode-types ( return types -- encoding ) @@ -36,7 +38,7 @@ IN: cocoa.subclassing ] map concat ; : prepare-method ( ret types quot -- type imp ) - >r [ encode-types ] 2keep r> [ + [ [ encode-types ] 2keep ] dip [ "cdecl" swap 4array % \ alien-callback , ] [ ] make define-temp ; @@ -45,28 +47,19 @@ IN: cocoa.subclassing [ first4 prepare-method 3array ] map ] with-compilation-unit ; -: types= ( a b -- ? ) - [ ascii alien>string ] bi@ = ; - -: (verify-method-type) ( class sel types -- ) - [ class_getInstanceMethod method_getTypeEncoding ] - dip types= - [ "Objective-C method types cannot be changed once defined" throw ] - unless ; -: verify-method-type ( class sel imp types -- class sel imp types ) - 4 ndup nip (verify-method-type) ; - -: (redefine-objc-method) ( class method -- ) - init-method ! verify-method-type - drop - [ class_getInstanceMethod ] dip method_setImplementation drop ; +:: (redefine-objc-method) ( class method -- ) + method init-method [| sel imp types | + class sel class_getInstanceMethod [ + imp method_setImplementation drop + ] [ + class sel imp types add-method + ] if* + ] call ; : redefine-objc-methods ( imeth name -- ) dup class-exists? [ - objc_getClass swap [ (redefine-objc-method) ] with each - ] [ - 2drop - ] if ; + objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each + ] [ 2drop ] if ; SYMBOL: +name+ SYMBOL: +protocols+ @@ -76,10 +69,10 @@ SYMBOL: +superclass+ clone [ prepare-methods +name+ get "cocoa.classes" create drop - +name+ get 2dup redefine-objc-methods swap [ - +protocols+ get , +superclass+ get , +name+ get , , - \ (define-objc-class) , - ] [ ] make import-objc-class + +name+ get 2dup redefine-objc-methods swap + +protocols+ get +superclass+ get +name+ get + '[ _ _ _ _ (define-objc-class) ] + import-objc-class ] bind ; : CLASS: diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index d03688b2be..be67f03184 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays kernel math namespaces make cocoa -cocoa.messages cocoa.classes cocoa.types sequences -continuations ; +USING: specialized-arrays.int arrays kernel math namespaces make +cocoa cocoa.messages cocoa.classes cocoa.types sequences +continuations accessors ; IN: cocoa.views : NSOpenGLPFAAllRenderers 1 ; @@ -69,12 +69,12 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] { } make >c-int-array + ] int-array{ } make underlying>> -> initWithAttributes: -> autorelease ; : ( class dim -- view ) - >r -> alloc 0 0 r> first2 + [ -> alloc 0 0 ] dip first2 -> initWithFrame:pixelFormat: dup 1 -> setPostsBoundsChangedNotifications: dup 1 -> setPostsFrameChangedNotifications: ; @@ -85,10 +85,11 @@ PRIVATE> swap NSRect-h >fixnum 2array ; : mouse-location ( view event -- loc ) - over >r - -> locationInWindow f -> convertPoint:fromView: - dup NSPoint-x swap NSPoint-y - r> -> frame NSRect-h swap - 2array ; + [ + -> locationInWindow f -> convertPoint:fromView: + [ NSPoint-x ] [ NSPoint-y ] bi + ] [ drop -> frame NSRect-h ] 2bi + swap - 2array ; USE: opengl.gl USE: alien.syntax diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index dd2d1bfd41..3a53a1cc3c 100644 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -34,5 +34,6 @@ IN: cocoa.windows dup 0 -> setReleasedWhenClosed: ; : window-content-rect ( window -- rect ) - NSWindow over -> frame rot -> styleMask + [ NSWindow ] dip + [ -> frame ] [ -> styleMask ] bi -> contentRectForFrameRect:styleMask: ; diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index 2b4e522789..d8bab4dd34 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -3,9 +3,13 @@ locals generalizations macros fry ; IN: combinators.short-circuit MACRO:: n&& ( quots n -- quot ) - [ f ] - quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map - [ n nnip ] suffix 1array + [ f ] quots [| q | + n + [ q '[ drop _ ndup @ dup not ] ] + [ '[ drop _ ndrop f ] ] + bi 2array + ] map + n '[ _ nnip ] suffix 1array [ cond ] 3append ; MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ; @@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ; MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ; MACRO:: n|| ( quots n -- quot ) - [ f ] - quots - [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map - { [ drop n ndrop t ] [ f ] } suffix 1array + [ f ] quots [| q | + n + [ q '[ drop _ ndup @ dup ] ] + [ '[ _ nnip ] ] + bi 2array + ] map + n '[ drop _ ndrop t ] [ f ] 2array suffix 1array [ cond ] 3append ; MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ; diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 65d290df3a..3d06bd97b7 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax parser vocabs.loader strings ; +USING: help.markup help.syntax parser vocabs.loader strings +command-line.private ; IN: command-line HELP: run-bootstrap-init @@ -7,7 +8,10 @@ HELP: run-bootstrap-init HELP: run-user-init { $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ; -HELP: cli-param +HELP: load-vocab-roots +{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } " on Unix and " { $snippet "factor-roots" } " on Windows." } ; + +HELP: param { $values { "param" string } } { $description "Process a command-line switch." $nl @@ -17,10 +21,13 @@ $nl $nl "Otherwise, sets the global variable named by the parameter to " { $link t } "." } ; -HELP: cli-args +HELP: (command-line) { $values { "args" "a sequence of strings" } } { $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ; +HELP: command-line +{ $var-description "The command line parameters which follow the name of the script on the command line." } ; + HELP: main-vocab-hook { $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ; @@ -35,9 +42,6 @@ HELP: ignore-cli-args? { $values { "?" "a boolean" } } { $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ; -HELP: parse-command-line -{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ; - ARTICLE: "runtime-cli-args" "Command line switches for the VM" "A handful of command line switches are processed by the VM and not the library. They control low-level features." { $table @@ -64,9 +68,12 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap" } "Bootstrap can load various optional components:" { $table + { { $snippet "math" } "Rational and complex number support." } + { { $snippet "threads" } "Thread support." } { { $snippet "compiler" } "The compiler." } { { $snippet "tools" } "Terminal-based developer tools." } { { $snippet "help" } "The help system." } + { { $snippet "help.handbook" } "The help handbook." } { { $snippet "ui" } "The graphical user interface." } { { $snippet "ui.tools" } "Graphical developer tools." } { { $snippet "io" } "Non-blocking I/O and networking." } @@ -86,7 +93,6 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage" { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } } { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } } { { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } } - { { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } } } ; ARTICLE: "factor-boot-rc" "Bootstrap initialization file" @@ -102,11 +108,18 @@ $nl "A word to run this file from an existing Factor session:" { $subsection run-user-init } ; +ARTICLE: "factor-roots" "Additional vocabulary roots file" +"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "." +$nl +"A word to run this file from an existing Factor session:" +{ $subsection load-vocab-roots } ; + ARTICLE: "rc-files" "Running code on startup" -"Factor looks for two files in your home directory." +"Factor looks for three optional files in your home directory." { $subsection "factor-boot-rc" } { $subsection "factor-rc" } -"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files." +{ $subsection "factor-roots" } +"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files." $nl "If you are unsure where the files should be located, evaluate the following code:" { $code @@ -122,8 +135,16 @@ $nl "100 dpi set-global" } ; -ARTICLE: "cli" "Command line usage" -"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "." +ARTICLE: "cli" "Command line arguments" +"Factor command line usage:" +{ $code "factor [system switches...] [script args...]" } +"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:" +{ $subsection command-line } +"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:" +{ $code "factor [system switches...] -run=" } +"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system." +$nl +"As stated above, arguments in the first part of the command line, before the optional script name, are interpreted by to the Factor system. These arguments all start with a dash (" { $snippet "-" } ")." $nl "Switches can take one of the following three forms:" { $list @@ -134,9 +155,9 @@ $nl { $subsection "runtime-cli-args" } { $subsection "bootstrap-cli-args" } { $subsection "standard-cli-args" } -"The list of command line arguments can be obtained and inspected directly:" -{ $subsection cli-args } -"There is a way to override the default vocabulary to run on startup:" +"The raw list of command line arguments can also be obtained and inspected directly:" +{ $subsection (command-line) } +"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:" { $subsection main-vocab-hook } ; ABOUT: "cli" diff --git a/basis/command-line/command-line-tests.factor b/basis/command-line/command-line-tests.factor deleted file mode 100644 index 226765bafe..0000000000 --- a/basis/command-line/command-line-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: namespaces tools.test kernel command-line ; -IN: command-line.tests - -[ - [ f ] [ "-no-user-init" cli-arg ] unit-test - [ f ] [ "user-init" get ] unit-test - - [ f ] [ "-user-init" cli-arg ] unit-test - [ t ] [ "user-init" get ] unit-test - - [ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test -] with-scope diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 7691f6877b..1b58053b64 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,10 +1,15 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init continuations debugger hashtables io kernel -kernel.private namespaces parser sequences strings system -splitting io.files eval ; +USING: init continuations debugger hashtables io +io.encodings.utf8 io.files kernel kernel.private namespaces +parser sequences strings system splitting eval vocabs.loader ; IN: command-line +SYMBOL: script +SYMBOL: command-line + +: (command-line) ( -- args ) 10 getenv sift ; + : rc-path ( name -- path ) os windows? [ "." prepend ] unless home prepend-path ; @@ -19,17 +24,33 @@ IN: command-line "factor-rc" rc-path ?run-file ] when ; -: cli-var-param ( name value -- ) swap set-global ; +: load-vocab-roots ( -- ) + "user-init" get [ + "factor-roots" rc-path dup exists? [ + utf8 file-lines [ add-vocab-root ] each + ] [ drop ] if + ] when ; -: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ; + + +: parse-command-line ( args -- ) + [ command-line off script off ] [ + unclip "-" ?head + [ param parse-command-line ] + [ script set command-line set ] if + ] if-empty ; SYMBOL: main-vocab-hook @@ -53,14 +74,17 @@ SYMBOL: main-vocab-hook : ignore-cli-args? ( -- ? ) os macosx? "run" get "ui" = and ; -: script-mode ( -- ) - t "quiet" set-global - "none" "run" set-global ; +: script-mode ( -- ) ; -: parse-command-line ( -- ) - cli-args [ cli-arg ] filter - "script" get [ script-mode ] when - ignore-cli-args? [ drop ] [ [ run-file ] each ] if - "e" get [ eval ] when* ; +: handle-command-line ( -- ) + [ + (command-line) parse-command-line + load-vocab-roots + run-user-init + "e" get [ eval ] when* + ignore-cli-args? not script get and + [ run-script ] [ "run" get run ] if* + output-stream get [ stream-flush ] when* + ] [ print-error 1 exit ] recover ; [ default-cli-args ] "command-line" add-init-hook diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index e414d6e29b..4a41014ab2 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -18,7 +18,7 @@ IN: compiler.alien dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ; : parameter-align ( n type -- n delta ) - over >r c-type-stack-align align dup r> - ; + [ c-type-stack-align align dup ] [ drop ] 2bi - ; : parameter-sizes ( types -- total offsets ) #! Compute stack frame locations. diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 98569d868c..90227bb5da 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces assocs hashtables sequences +USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.copy-prop ; @@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ; M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; +M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; M: ##peek insn-object loc>> class ; M: ##replace insn-object loc>> class ; @@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; +M: ##alien-global insn-object drop \ ##alien-global ; : init-alias-analysis ( -- ) H{ } clone histories set @@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases* M: ##load-indirect analyze-aliases* dup dst>> set-heap-ac ; +M: ##alien-global analyze-aliases* + dup dst>> set-heap-ac ; + M: ##allot analyze-aliases* #! A freshly allocated object is distinct from any other #! object. diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 7bad44f7a6..9ffe4a6aa0 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -21,8 +21,6 @@ IN: compiler.cfg.builder ! Convert tree SSA IR to CFG SSA IR. -: stop-iterating ( -- next ) end-basic-block f ; - SYMBOL: procedures SYMBOL: current-word SYMBOL: current-label @@ -211,7 +209,7 @@ M: #dispatch emit-node ! #call M: #call emit-node dup word>> dup "intrinsic" word-prop - [ emit-intrinsic iterate-next ] [ nip emit-call ] if ; + [ emit-intrinsic ] [ nip emit-call ] if ; ! #call-recursive M: #call-recursive emit-node label>> id>> emit-call ; @@ -262,7 +260,7 @@ M: #terminate emit-node drop stop-iterating ; : emit-alien-node ( node quot -- next ) [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi - begin-basic-block iterate-next ; inline + ##branch begin-basic-block iterate-next ; inline M: #alien-invoke emit-node [ ##alien-invoke ] emit-alien-node ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 7553407e00..068a6a6377 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -12,9 +12,15 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##unary/temp defs-vregs dst/tmp-vregs ; M: ##allot defs-vregs dst/tmp-vregs ; M: ##dispatch defs-vregs temp>> 1array ; -M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ; +M: ##slot defs-vregs dst/tmp-vregs ; M: ##set-slot defs-vregs temp>> 1array ; -M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ; +M: ##string-nth defs-vregs dst/tmp-vregs ; +M: ##set-string-nth-fast defs-vregs temp>> 1array ; +M: ##compare defs-vregs dst/tmp-vregs ; +M: ##compare-imm defs-vregs dst/tmp-vregs ; +M: ##compare-float defs-vregs dst/tmp-vregs ; +M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ; +M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: insn defs-vregs drop f ; M: ##unary uses-vregs src>> 1array ; @@ -26,11 +32,13 @@ M: ##slot-imm uses-vregs obj>> 1array ; M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ; M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ; M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ; +M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ; M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##compare-imm-branch uses-vregs src1>> 1array ; M: ##dispatch uses-vregs src>> 1array ; M: ##alien-getter uses-vregs src>> 1array ; M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; +M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: insn uses-vregs drop f ; @@ -40,6 +48,7 @@ UNION: vreg-insn ##write-barrier ##dispatch ##effect +##fixnum-overflow ##conditional-branch ##compare-imm-branch _conditional-branch diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index e6e05abbd5..c0d5bf79a6 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -39,6 +39,7 @@ IN: compiler.cfg.hats : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline : ^^not ( src -- dst ) ^^i1 ##not ; inline +: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline : ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline : ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline : ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline @@ -65,9 +66,10 @@ IN: compiler.cfg.hats : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline -: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline -: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline -: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline +: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline +: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline +: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline +: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b2c752e612..5619a70740 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ; ! String element access INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ; +INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ; ! Integer arithmetic INSN: ##add < ##commutative ; @@ -91,6 +92,16 @@ INSN: ##shl-imm < ##binary-imm ; INSN: ##shr-imm < ##binary-imm ; INSN: ##sar-imm < ##binary-imm ; INSN: ##not < ##unary ; +INSN: ##log2 < ##unary ; + +! Overflowing arithmetic +TUPLE: ##fixnum-overflow < insn src1 src2 ; +INSN: ##fixnum-add < ##fixnum-overflow ; +INSN: ##fixnum-add-tail < ##fixnum-overflow ; +INSN: ##fixnum-sub < ##fixnum-overflow ; +INSN: ##fixnum-sub-tail < ##fixnum-overflow ; +INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ; +INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ; : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline @@ -151,6 +162,8 @@ INSN: ##set-alien-double < ##alien-setter ; INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##write-barrier < ##effect card# table ; +INSN: ##alien-global < ##read symbol library ; + ! FFI INSN: ##alien-invoke params ; INSN: ##alien-indirect params ; @@ -198,11 +211,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; INSN: ##compare-branch < ##conditional-branch ; INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ; -INSN: ##compare < ##binary cc ; -INSN: ##compare-imm < ##binary-imm cc ; +INSN: ##compare < ##binary cc temp ; +INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; -INSN: ##compare-float < ##binary cc ; +INSN: ##compare-float < ##binary cc temp ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 04c9097725..3ad716d847 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -3,10 +3,21 @@ USING: sequences accessors layouts kernel math namespaces combinators fry locals compiler.tree.propagation.info -compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.hats +compiler.cfg.stacks +compiler.cfg.iterator +compiler.cfg.instructions +compiler.cfg.utilities +compiler.cfg.registers ; IN: compiler.cfg.intrinsics.fixnum +: emit-both-fixnums? ( -- ) + 2inputs + ^^or + tag-mask get ^^and-imm + 0 cc= ^^compare-imm + ds-push ; + : (emit-fixnum-imm-op) ( infos insn -- dst ) ds-drop [ ds-pop ] @@ -42,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum-bitnot ( -- ) ds-pop ^^not tag-mask get ^^xor-imm ds-push ; +: emit-fixnum-log2 ( -- ) + ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ; + : (emit-fixnum*fast) ( -- dst ) 2inputs ^^untag-fixnum ^^mul ; @@ -64,3 +78,16 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum>bignum ( -- ) ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; + +: emit-fixnum-overflow-op ( quot quot-tail -- next ) + [ 2inputs 1 ##inc-d ] 2dip + tail-call? [ + ##epilogue + nip call + stop-iterating + ] [ + drop call + ##branch + begin-basic-block + iterate-next + ] if ; inline diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ef1cde337a..6656cd11f7 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -8,7 +8,9 @@ compiler.cfg.intrinsics.alien compiler.cfg.intrinsics.allot compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float -compiler.cfg.intrinsics.slots ; +compiler.cfg.intrinsics.slots +compiler.cfg.intrinsics.misc +compiler.cfg.iterator ; QUALIFIED: kernel QUALIFIED: arrays QUALIFIED: byte-arrays @@ -17,11 +19,17 @@ QUALIFIED: slots.private QUALIFIED: strings.private QUALIFIED: classes.tuple.private QUALIFIED: math.private +QUALIFIED: math.integers.private QUALIFIED: alien.accessors IN: compiler.cfg.intrinsics { kernel.private:tag + kernel.private:getenv + math.private:both-fixnums? + math.private:fixnum+ + math.private:fixnum- + math.private:fixnum* math.private:fixnum+fast math.private:fixnum-fast math.private:fixnum-bitand @@ -40,6 +48,7 @@ IN: compiler.cfg.intrinsics slots.private:slot slots.private:set-slot strings.private:string-nth + strings.private:set-string-nth-fast classes.tuple.private: arrays: byte-arrays: @@ -85,60 +94,70 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-double } [ t "intrinsic" set-word-prop ] each ; -: emit-intrinsic ( node word -- ) +: enable-fixnum-log2 ( -- ) + \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; + +: emit-intrinsic ( node word -- node/f ) { - { \ kernel.private:tag [ drop emit-tag ] } - { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } - { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } - { \ math.private:fixnum*fast [ emit-fixnum*fast ] } - { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } - { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } - { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } - { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } - { \ kernel:eq? [ cc= emit-fixnum-comparison ] } - { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } - { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } - { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } - { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } - { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } - { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } - { \ math.private:float< [ drop cc< emit-float-comparison ] } - { \ math.private:float<= [ drop cc<= emit-float-comparison ] } - { \ math.private:float>= [ drop cc>= emit-float-comparison ] } - { \ math.private:float> [ drop cc> emit-float-comparison ] } - { \ math.private:float= [ drop cc= emit-float-comparison ] } - { \ math.private:float>fixnum [ drop emit-float>fixnum ] } - { \ math.private:fixnum>float [ drop emit-fixnum>float ] } - { \ slots.private:slot [ emit-slot ] } - { \ slots.private:set-slot [ emit-set-slot ] } - { \ strings.private:string-nth [ drop emit-string-nth ] } - { \ classes.tuple.private: [ emit- ] } - { \ arrays: [ emit- ] } - { \ byte-arrays: [ emit- ] } - { \ math.private: [ emit-simple-allot ] } - { \ math.private: [ emit-simple-allot ] } - { \ kernel: [ emit-simple-allot ] } - { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } - { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } - { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } - { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] } - { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } - { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] } - { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] } - { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] } - { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] } + { \ kernel.private:tag [ drop emit-tag iterate-next ] } + { \ kernel.private:getenv [ emit-getenv iterate-next ] } + { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] } + { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } + { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } + { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] } + { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] } + { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] } + { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] } + { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] } + { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] } + { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] } + { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] } + { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] } + { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] } + { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] } + { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] } + { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] } + { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] } + { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] } + { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] } + { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] } + { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] } + { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] } + { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] } + { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] } + { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] } + { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] } + { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] } + { \ slots.private:slot [ emit-slot iterate-next ] } + { \ slots.private:set-slot [ emit-set-slot iterate-next ] } + { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] } + { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] } + { \ classes.tuple.private: [ emit- iterate-next ] } + { \ arrays: [ emit- iterate-next ] } + { \ byte-arrays: [ emit- iterate-next ] } + { \ math.private: [ emit-simple-allot iterate-next ] } + { \ math.private: [ emit-simple-allot iterate-next ] } + { \ kernel: [ emit-simple-allot iterate-next ] } + { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } + { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } + { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] } + { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] } + { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] } + { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] } + { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] } + { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] } + { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] } + { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] } + { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] } + { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] } + { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] } + { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] } + { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] } + { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] } + { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] } + { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] } } case ; diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor new file mode 100644 index 0000000000..f9f2182a4e --- /dev/null +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces layouts sequences kernel +accessors compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.misc + +: emit-tag ( -- ) + ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; + +: emit-getenv ( node -- ) + "userenv" f ^^alien-global + swap node-input-infos first literal>> + [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if* + ds-push ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index fec234a576..bc46e6149c 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.intrinsics.slots -: emit-tag ( -- ) - ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; - : value-tag ( info -- n ) class>> class-tag ; inline : (emit-slot) ( infos -- dst ) @@ -54,3 +51,7 @@ IN: compiler.cfg.intrinsics.slots : emit-string-nth ( -- ) 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ; + +: emit-set-string-nth-fast ( -- ) + 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri* + swap i ##set-string-nth-fast ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index ec9ffaba49..d545b6d15c 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -34,6 +34,12 @@ M: insn compute-stack-frame* \ _gc t frame-required? set-word-prop \ _spill t frame-required? set-word-prop +\ ##fixnum-add t frame-required? set-word-prop +\ ##fixnum-sub t frame-required? set-word-prop +\ ##fixnum-mul t frame-required? set-word-prop +\ ##fixnum-add-tail f frame-required? set-word-prop +\ ##fixnum-sub-tail f frame-required? set-word-prop +\ ##fixnum-mul-tail f frame-required? set-word-prop : compute-stack-frame ( insns -- ) frame-required? off diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index e943fb4828..dabecaeec4 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel sequences sequences.deep +USING: accessors arrays kernel sequences compiler.utilities compiler.cfg.instructions cpu.architecture ; IN: compiler.cfg.two-operand @@ -55,6 +55,6 @@ M: insn convert-two-operand* ; : convert-two-operand ( mr -- mr' ) [ two-operand? [ - [ convert-two-operand* ] map flatten + [ convert-two-operand* ] map-flat ] when ] change-instructions ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index cef14d06e4..99a138a763 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -33,5 +33,7 @@ IN: compiler.cfg.utilities building off basic-block off ; +: stop-iterating ( -- next ) end-basic-block f ; + : emit-primitive ( node -- ) word>> ##call ##branch begin-basic-block ; diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor index a3c9725838..d5c9830c0b 100644 --- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor +++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor @@ -62,4 +62,8 @@ M: ##compare-imm-branch propagate M: ##dispatch propagate [ resolve ] change-src ; +M: ##fixnum-overflow propagate + [ resolve ] change-src1 + [ resolve ] change-src2 ; + M: insn propagate ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 5f67f8097e..990543ed7a 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences layouts accessors combinators namespaces math fry +compiler.cfg.hats compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.simplify @@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison M: ##compare-imm rewrite-tagged-comparison [ dst>> ] [ (rewrite-tagged-comparison) ] bi - f \ ##compare-imm boa ; + i f \ ##compare-imm boa ; M: ##compare-imm-branch rewrite dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when @@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite [ dst>> ] [ src2>> ] [ src1>> vreg>vn vn>constant ] tri - cc= f \ ##compare-imm boa ; + cc= f i \ ##compare-imm boa ; M: ##compare rewrite dup flip-comparison? [ @@ -95,9 +96,9 @@ M: ##compare rewrite : rewrite-redundant-comparison ( insn -- insn' ) [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { - { \ ##compare [ >compare-expr< f \ ##compare boa ] } - { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] } - { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] } + { \ ##compare [ >compare-expr< i f \ ##compare boa ] } + { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] } + { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] } } case swap cc= eq? [ [ negate-cc ] change-cc ] when ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index b73736ed14..8adeaa21f4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,6 +1,17 @@ IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions -compiler.cfg.registers cpu.architecture tools.test kernel math ; +compiler.cfg.registers cpu.architecture tools.test kernel math +combinators.short-circuit accessors sequences ; + +: trim-temps ( insns -- insns ) + [ + dup { + [ ##compare? ] + [ ##compare-imm? ] + [ ##compare-float? ] + } 1|| [ f >>temp ] when + ] map ; + [ { T{ ##peek f V int-regs 45 D 1 } @@ -82,7 +93,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } T{ ##replace f V int-regs 6 D 0 } - } value-numbering + } value-numbering trim-temps ] unit-test [ @@ -100,7 +111,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } T{ ##replace f V int-regs 6 D 0 } - } value-numbering + } value-numbering trim-temps ] unit-test [ @@ -122,7 +133,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } T{ ##replace f V int-regs 14 D 0 } - } value-numbering + } value-numbering trim-temps ] unit-test [ @@ -138,5 +149,5 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##peek f V int-regs 30 D -2 } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare-imm-branch f V int-regs 33 7 cc/= } - } value-numbering + } value-numbering trim-temps ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 9f6e8e9c9b..9f134c02d7 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -131,6 +131,14 @@ M: ##string-nth generate-insn [ temp>> register ] } cleave %string-nth ; +M: ##set-string-nth-fast generate-insn + { + [ src>> register ] + [ obj>> register ] + [ index>> register ] + [ temp>> register ] + } cleave %set-string-nth-fast ; + : dst/src ( insn -- dst src ) [ dst>> register ] [ src>> register ] bi ; inline @@ -155,6 +163,20 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ; M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ; M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; M: ##not generate-insn dst/src %not ; +M: ##log2 generate-insn dst/src %log2 ; + +: src1/src2 ( insn -- src1 src2 ) + [ src1>> register ] [ src2>> register ] bi ; inline + +: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 ) + [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline + +M: ##fixnum-add generate-insn src1/src2 %fixnum-add ; +M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ; +M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ; +M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ; +M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ; +M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ; : dst/src/temp ( insn -- dst src temp ) [ dst/src ] [ temp>> register ] bi ; inline @@ -215,6 +237,10 @@ M: _gc generate-insn drop %gc ; M: ##loop-entry generate-insn drop %loop-entry ; +M: ##alien-global generate-insn + [ dst>> register ] [ symbol>> ] [ library>> ] tri + %alien-global ; + ! ##alien-invoke GENERIC: reg-size ( register-class -- n ) @@ -264,7 +290,7 @@ M: object reg-class-full? : spill-param ( reg-class -- n reg-class ) stack-params get - >r reg-size cell align stack-params +@ r> + [ reg-size cell align stack-params +@ ] dip stack-params ; : fastcall-param ( reg-class -- n reg-class ) @@ -300,10 +326,10 @@ M: long-long-type flatten-value-type ( type -- types ) ] { } make ; : each-parameter ( parameters quot -- ) - >r [ parameter-sizes nip ] keep r> 2each ; inline + [ [ parameter-sizes nip ] keep ] dip 2each ; inline : reverse-each-parameter ( parameters quot -- ) - >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline + [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline : reset-freg-counts ( -- ) { int-regs float-regs stack-params } [ 0 swap set ] each ; @@ -316,15 +342,13 @@ M: long-long-type flatten-value-type ( type -- types ) #! Moves values from C stack to registers (if word is #! %load-param-reg) and registers to C stack (if word is #! %save-param-reg). - >r - alien-parameters - flatten-value-types - r> '[ alloc-parameter _ execute ] each-parameter ; - inline + [ alien-parameters flatten-value-types ] + [ '[ alloc-parameter _ execute ] ] + bi* each-parameter ; inline : unbox-parameters ( offset node -- ) parameters>> [ - %prepare-unbox >r over + r> unbox-parameter + %prepare-unbox [ over + ] dip unbox-parameter ] reverse-each-parameter drop ; : prepare-box-struct ( node -- offset ) @@ -432,7 +456,7 @@ M: ##alien-indirect generate-insn TUPLE: callback-context ; -: current-callback 2 getenv ; +: current-callback ( -- id ) 2 getenv ; : wait-to-return ( token -- ) dup current-callback eq? [ @@ -491,9 +515,10 @@ M: _label generate-insn M: _branch generate-insn label>> lookup-label %jump-label ; -: >compare< ( insn -- label cc src1 src2 ) +: >compare< ( insn -- dst temp cc src1 src2 ) { [ dst>> register ] + [ temp>> register ] [ cc>> ] [ src1>> register ] [ src2>> ?register ] diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index b25f1fa8fe..a56ae04a7b 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -9,7 +9,7 @@ IN: compiler.codegen.fixup GENERIC: fixup* ( obj -- ) -: code-format 22 getenv ; +: code-format ( -- n ) 22 getenv ; : compiled-offset ( -- n ) building get length code-format * ; @@ -46,28 +46,27 @@ M: integer fixup* , ; : indq ( elt seq -- n ) [ eq? ] with find drop ; : adjoin* ( obj table -- n ) - 2dup indq [ 2nip ] [ dup length >r push r> ] if* ; + 2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ; SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get adjoin* ; : add-dlsym-literals ( symbol dll -- ) - >r string>symbol r> 2array literal-table get push-all ; + [ string>symbol ] dip 2array literal-table get push-all ; : rel-dlsym ( name dll class -- ) - >r literal-table get length >r - add-dlsym-literals - r> r> rt-dlsym rel-fixup ; + [ literal-table get length [ add-dlsym-literals ] dip ] dip + rt-dlsym rel-fixup ; : rel-word ( word class -- ) - >r add-literal r> rt-xt rel-fixup ; + [ add-literal ] dip rt-xt rel-fixup ; : rel-primitive ( word class -- ) - >r def>> first r> rt-primitive rel-fixup ; + [ def>> first ] dip rt-primitive rel-fixup ; -: rel-literal ( literal class -- ) - >r add-literal r> rt-literal rel-fixup ; +: rel-immediate ( literal class -- ) + [ add-literal ] dip rt-immediate rel-fixup ; : rel-this ( class -- ) 0 swap rt-label rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 86c1f65049..48ea958818 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -39,13 +39,12 @@ IN: compiler.constants ! Relocation types : rt-primitive 0 ; inline : rt-dlsym 1 ; inline -: rt-literal 2 ; inline -: rt-dispatch 3 ; inline -: rt-xt 4 ; inline -: rt-here 5 ; inline -: rt-label 6 ; inline -: rt-immediate 7 ; inline -: rt-stack-chain 8 ; inline +: rt-dispatch 2 ; inline +: rt-xt 3 ; inline +: rt-here 4 ; inline +: rt-label 5 ; inline +: rt-immediate 6 ; inline +: rt-stack-chain 7 ; inline : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index abcdb46ea2..230a7bf542 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences stack-checker stack-checker.errors words arrays parser quotations continuations effects namespaces.private io io.streams.string -memory system threads tools.test math accessors combinators ; +memory system threads tools.test math accessors combinators +specialized-arrays.float ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -196,7 +197,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test +[ 32.0 ] [ + { 1.0 2.0 3.0 } >float-array underlying>> + { 4.0 5.0 6.0 } >float-array underlying>> + ffi_test_23 +] unit-test ! Test odd-size structs C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index a56ee55c82..e743c8484b 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io -combinators vectors float-arrays ; +combinators vectors grouping make ; IN: compiler.tests ! Originally, this file did black box testing of templating @@ -241,3 +241,38 @@ TUPLE: id obj ; [ "a" ] [ 1 test-2 ] unit-test [ "b" ] [ 2 test-2 ] unit-test + +! I accidentally fixnum/i-fast on PowerPC +[ { { 1 2 } { 3 4 } } ] [ + { 1 2 3 4 } + [ + [ { array } declare 2 [ , ] each ] compile-call + ] { } make +] unit-test + +[ 2 ] [ + { 1 2 3 4 } + [ { array } declare 2 length ] compile-call +] unit-test + +! Oops with new intrinsics +: fixnum-overflow-control-flow-test ( a b -- c ) + [ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ; + +[ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test +[ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test + +! LOL +: blah ( a -- b ) + { float } declare dup 0 = + [ drop 1 ] [ + dup 0 >= + [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ] + [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ] + if + ] if ; + +[ 4.0 ] [ 2.0 blah ] unit-test + +[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test +[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index c90a31fc61..df5f484952 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -160,6 +160,11 @@ IN: compiler.tests [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test +[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test +[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test +[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test +[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test + [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test @@ -208,6 +213,7 @@ IN: compiler.tests [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test +[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test [ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test [ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index f1b3e32eed..41df6e7ae5 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ; HINTS: recursive-inline-hang-3 array ; ! Regression -USE: sequences.private - -[ ] [ { (3append) } compile ] unit-test +[ ] [ { 3append-as } compile ] unit-test ! Wow : counter-example ( a b c d -- a' b' c' d' ) diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 156fdfff02..ee8c2f056a 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,5 +1,5 @@ USING: math.private kernel combinators accessors arrays -generalizations float-arrays tools.test ; +generalizations tools.test ; IN: compiler.tests : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4e79c4cd2d..b715223445 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -21,7 +21,7 @@ IN: compiler.tree.builder : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] + [ >vector \ meta-d set ] [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4a6198db37..71c6fb5675 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -71,7 +71,7 @@ M: object xyz ; 2over fixnum>= [ 3drop ] [ - [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat) + [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat) ] if ; inline recursive : fx-repeat ( n quot -- ) @@ -87,10 +87,10 @@ M: object xyz ; 2over dup xyz drop >= [ 3drop ] [ - [ swap >r call 1+ r> ] keep (i-repeat) + [ swap [ call 1+ ] dip ] keep (i-repeat) ] if ; inline recursive -: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline +: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline [ t ] [ [ [ dup xyz drop ] i-repeat ] \ xyz inlined? @@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ; 2dup >= [ 2drop ] [ - >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2) + [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) ] if ; inline recursive : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline @@ -448,7 +448,7 @@ cell-bits 32 = [ ] unit-test [ ] [ - [ [ >r "A" throw r> ] [ "B" throw ] if ] + [ [ [ "A" throw ] dip ] [ "B" throw ] if ] cleaned-up-tree drop ] unit-test @@ -463,7 +463,7 @@ cell-bits 32 = [ : buffalo-wings ( i seq -- ) 2dup < [ 2dup chicken-fingers - >r 1+ r> buffalo-wings + [ 1+ ] dip buffalo-wings ] [ 2drop ] if ; inline recursive @@ -482,7 +482,7 @@ cell-bits 32 = [ : ribs ( i seq -- ) 2dup < [ steak - >r 1+ r> ribs + [ 1+ ] dip ribs ] [ 2drop ] if ; inline recursive diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index becac01cd5..1b0343faa9 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences sequences.deep combinators fry +USING: kernel accessors sequences combinators fry classes.algebra namespaces assocs words math math.private math.partial-dispatch math.intervals classes classes.tuple classes.tuple.private layouts definitions stack-checker.state stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup ( nodes -- nodes' ) #! We don't recurse into children here, instead the methods #! do it since the logic is a bit more involved - [ cleanup* ] map flatten ; + [ cleanup* ] map-flat ; : cleanup-folding? ( #call -- ? ) node-output-infos diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 40bbf81a03..030df8484f 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs fry kernel accessors sequences sequences.deep arrays -stack-checker.inlining namespaces compiler.tree ; +USING: assocs fry kernel accessors sequences compiler.utilities +arrays stack-checker.inlining namespaces compiler.tree +math.order ; IN: compiler.tree.combinators : each-node ( nodes quot: ( node -- ) -- ) @@ -27,7 +28,7 @@ IN: compiler.tree.combinators [ _ map-nodes ] change-child ] when ] if - ] map flatten ; inline recursive + ] map-flat ; inline recursive : contains-node? ( nodes quot: ( node -- ? ) -- ? ) dup dup '[ @@ -48,12 +49,6 @@ IN: compiler.tree.combinators : sift-children ( seq flags -- seq' ) zip [ nip ] assoc-filter keys ; -: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline - -: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline - -: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline - : until-fixed-point ( #recursive quot: ( node -- ) -- ) over label>> t >>fixed-point drop [ with-scope ] 2keep diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7b15fdf856..b64e30d8f9 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests remove-dead-code "no-check" get [ dup check-nodes ] unless nodes>quot ; -[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test +[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test -[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test +[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test [ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor index 44b71935c8..9ece5d340b 100644 --- a/basis/compiler/tree/dead-code/liveness/liveness.factor +++ b/basis/compiler/tree/dead-code/liveness/liveness.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs deques search-deques -dlists kernel sequences sequences.deep words sets +dlists kernel sequences compiler.utilities words sets stack-checker.branches compiler.tree compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.dead-code.liveness @@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' ) M: node remove-dead-code* ; : (remove-dead-code) ( nodes -- nodes' ) - [ remove-dead-code* ] map flatten ; + [ remove-dead-code* ] map-flat ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index a1d8773484..8d764a2833 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -93,7 +93,7 @@ M: #shuffle node>quot [ drop "COMPLEX SHUFFLE" , ] } cond ; -M: #push node>quot literal>> , ; +M: #push node>quot literal>> literalize , ; M: #call node>quot word>> , ; @@ -125,9 +125,13 @@ M: node node>quot drop ; : nodes>quot ( node -- quot ) [ [ node>quot ] each ] [ ] make ; -: optimized. ( quot/word -- ) - dup word? [ specialized-def ] when - build-tree optimize-tree nodes>quot . ; +GENERIC: optimized. ( quot/word -- ) + +M: method-spec optimized. first2 method optimized. ; + +M: word optimized. specialized-def optimized. ; + +M: callable optimized. build-tree optimize-tree nodes>quot . ; SYMBOL: words-called SYMBOL: generics-called diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor index edfe633057..9b2a2038da 100644 --- a/basis/compiler/tree/def-use/simplified/simplified.factor +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences sequences.deep kernel +USING: sequences kernel fry vectors compiler.tree compiler.tree.def-use ; IN: compiler.tree.def-use.simplified @@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified ! A 'real' usage is a usage of a value that is not a #renaming. TUPLE: real-usage value node ; -GENERIC: actually-used-by* ( value node -- real-usages ) - ! Def GENERIC: actually-defined-by* ( value node -- real-usage ) @@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ; M: node actually-defined-by* real-usage boa ; ! Use -: (actually-used-by) ( value -- real-usages ) - dup used-by [ actually-used-by* ] with map ; +GENERIC# actually-used-by* 1 ( value node accum -- ) + +: (actually-used-by) ( value accum -- ) + [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ; M: #renaming actually-used-by* - inputs/outputs [ indices ] dip nths - [ (actually-used-by) ] map ; + [ inputs/outputs [ indices ] dip nths ] dip + '[ _ (actually-used-by) ] each ; -M: #return-recursive actually-used-by* real-usage boa ; +M: #return-recursive actually-used-by* [ real-usage boa ] dip push ; -M: node actually-used-by* real-usage boa ; +M: node actually-used-by* [ real-usage boa ] dip push ; : actually-used-by ( value -- real-usages ) - (actually-used-by) flatten ; + 10 [ (actually-used-by) ] keep ; diff --git a/basis/compiler/tree/escape-analysis/branches/branches.factor b/basis/compiler/tree/escape-analysis/branches/branches.factor index b728e9a1ba..2eee3e698b 100644 --- a/basis/compiler/tree/escape-analysis/branches/branches.factor +++ b/basis/compiler/tree/escape-analysis/branches/branches.factor @@ -33,4 +33,4 @@ M: #branch escape-analysis* 2bi ; M: #phi escape-analysis* - [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ; + [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ; diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor new file mode 100644 index 0000000000..333b3fa636 --- /dev/null +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes classes.tuple math math.private accessors +combinators kernel compiler.tree compiler.tree.combinators +compiler.tree.propagation.info ; +IN: compiler.tree.escape-analysis.check + +GENERIC: run-escape-analysis* ( node -- ? ) + +M: #push run-escape-analysis* + literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ; + +M: #call run-escape-analysis* + { + { [ dup word>> \ eq? ] [ t ] } + { [ dup immutable-tuple-boa? ] [ t ] } + [ f ] + } cond nip ; + +M: node run-escape-analysis* drop f ; + +: run-escape-analysis? ( nodes -- ? ) + [ run-escape-analysis* ] contains-node? ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 16a27e020a..ecd5429baf 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences words memoize classes.builtin +USING: kernel accessors sequences words memoize combinators +classes classes.builtin classes.tuple math.partial-dispatch fry assocs compiler.tree compiler.tree.combinators @@ -12,7 +13,7 @@ IN: compiler.tree.finalization ! See the comment in compiler.tree.late-optimizations. ! This pass runs after propagation, so that it can expand -! built-in type predicates; these cannot be expanded before +! type predicates; these cannot be expanded before ! propagation since we need to see 'fixnum?' instead of ! 'tag 0 eq?' and so on, for semantic reasoning. @@ -33,16 +34,24 @@ M: #shuffle finalize* [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] bi and [ drop f ] when ; -: builtin-predicate? ( #call -- ? ) - word>> "predicating" word-prop builtin-class? ; - -MEMO: builtin-predicate-expansion ( word -- nodes ) +MEMO: cached-expansion ( word -- nodes ) def>> splice-final ; -: expand-builtin-predicate ( #call -- nodes ) - word>> builtin-predicate-expansion ; +GENERIC: finalize-word ( #call word -- nodes ) + +M: predicate finalize-word + "predicating" word-prop { + { [ dup builtin-class? ] [ drop word>> cached-expansion ] } + { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + [ drop ] + } cond ; + +! M: math-partial finalize-word +! dup primitive? [ drop ] [ nip cached-expansion ] if ; + +M: word finalize-word drop ; M: #call finalize* - dup builtin-predicate? [ expand-builtin-predicate ] when ; + dup word>> finalize-word ; M: node finalize* ; diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index c4a97fcc92..5ac3c57abe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ; [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test DEFER: bbb -: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive -: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive +: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive +: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive [ ] [ [ bbb ] test-normalization ] unit-test diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index bebe2e91b6..8c13de296a 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math accessors kernel arrays -combinators sequences.deep assocs +combinators compiler.utilities assocs stack-checker.backend stack-checker.branches stack-checker.inlining +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.normalization.introductions @@ -46,7 +47,7 @@ M: #branch normalize* [ [ [ - [ normalize* ] map flatten + [ normalize* ] map-flat introduction-stack get 2array ] with-scope @@ -70,7 +71,7 @@ M: #phi normalize* : (normalize) ( nodes introductions -- nodes ) introduction-stack [ - [ normalize* ] map flatten + [ normalize* ] map-flat ] with-variable ; M: #recursive normalize* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index e37323a2ec..54c6c2c117 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -6,6 +6,7 @@ compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis +compiler.tree.escape-analysis.check compiler.tree.tuple-unboxing compiler.tree.identities compiler.tree.def-use @@ -22,8 +23,10 @@ SYMBOL: check-optimizer? normalize propagate cleanup - escape-analysis - unbox-tuples + dup run-escape-analysis? [ + escape-analysis + unbox-tuples + ] when apply-identities compute-def-use remove-dead-code diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 424cd8a01c..f2613022fc 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -3,6 +3,7 @@ USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -78,7 +79,7 @@ SYMBOL: condition-value M: #phi propagate-before ( #phi -- ) [ annotate-phi-inputs ] - [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ] + [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; : branch-phi-constraints ( output values booleans -- ) @@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- ) M: #phi propagate-after ( #phi -- ) condition-value get [ [ out-d>> ] - [ phi-in-d>> ] - [ phi-info-d>> ] tri + [ phi-in-d>> flip ] + [ phi-info-d>> flip ] tri [ [ possible-boolean-values ] map branch-phi-constraints diff --git a/basis/compiler/tree/propagation/copy/copy.factor b/basis/compiler/tree/propagation/copy/copy.factor index 2452aba4aa..53b7d17326 100644 --- a/basis/compiler/tree/propagation/copy/copy.factor +++ b/basis/compiler/tree/propagation/copy/copy.factor @@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ; ] 2each ; M: #phi compute-copy-equiv* - [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ; + [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ; M: node compute-copy-equiv* drop ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 8397a5fdbb..fcc3b01dc0 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations +words namespaces continuations classes fry compiler.tree compiler.tree.builder compiler.tree.recursive @@ -20,13 +20,17 @@ SYMBOL: node-count : count-nodes ( nodes -- ) 0 swap [ drop 1+ ] each-node node-count set ; +! We try not to inline the same word too many times, to avoid +! combinatorial explosion +SYMBOL: inlining-count + ! Splicing nodes GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; -M: quotation splicing-nodes +M: callable splicing-nodes build-sub-tree analyze-recursive normalize ; : propagate-body ( #call -- ) @@ -85,6 +89,8 @@ DEFER: (flat-length) : word-flat-length ( word -- n ) { + ! special-case + { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] } ! not inline { [ dup inline? not ] [ drop 1 ] } ! recursive and inline @@ -118,17 +124,25 @@ DEFER: (flat-length) bi and ] contains? ; +: node-count-bias ( -- n ) + 45 node-count get [-] 8 /i ; + +: body-length-bias ( word -- n ) + [ flat-length ] [ inlining-count get at 0 or ] bi + over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ; + : inlining-rank ( #call word -- n ) [ classes-known? 2 0 ? ] [ { - [ drop node-count get 45 swap [-] 8 /i ] - [ flat-length 24 swap [-] 4 /i ] + [ body-length-bias ] [ "default" word-prop -4 0 ? ] [ "specializer" word-prop 1 0 ? ] [ method-body? 1 0 ? ] } cleave - ] bi* + + + + + ; + node-count-bias + loop-nesting get 0 or 2 * + ] bi* + + + + + + ; : should-inline? ( #call word -- ? ) dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; @@ -136,20 +150,23 @@ DEFER: (flat-length) SYMBOL: history : remember-inlining ( word -- ) - history [ swap suffix ] change ; + [ [ 1 ] dip inlining-count get at+ ] + [ history [ swap suffix ] change ] + bi ; -: inline-word ( #call word -- ? ) - dup history get memq? [ - 2drop f - ] [ +: inline-word-def ( #call word quot -- ? ) + over history get memq? [ 3drop f ] [ [ - dup remember-inlining - dupd def>> splicing-nodes >>body + swap remember-inlining + dupd splicing-nodes >>body propagate-body ] with-scope t ] if ; +: inline-word ( #call word -- ? ) + dup def>> inline-word-def ; + : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -163,7 +180,11 @@ SYMBOL: history [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack first object swap eliminate-dispatch ; -: do-inlining ( #call word -- ? ) +: inline-instance-check ( #call word -- ? ) + over in-d>> second value-info literal>> dup class? + [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; + +: (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition #! is built at the end of the compilation unit. We do not @@ -174,10 +195,17 @@ SYMBOL: history #! discouraged, but it should still work.) { { [ dup deferred? ] [ 2drop f ] } - { [ dup custom-inlining? ] [ inline-custom ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup method-body? ] [ inline-method-body ] } [ 2drop f ] } cond ; + +: do-inlining ( #call word -- ? ) + #! Note the logic here: if there's a custom inlining hook, + #! it is permitted to return f, which means that we try the + #! normal inlining heuristic. + dup custom-inlining? [ 2dup inline-custom ] [ f ] if + [ 2drop t ] [ (do-inlining) ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index f6e2bc0940..8242311287 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -definitions +definitions strings.private vectors hashtables stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -37,31 +37,6 @@ most-negative-fixnum most-positive-fixnum [a,b] \ bitnot { integer } "input-classes" set-word-prop -{ - fcosh - flog - fsinh - fexp - fasin - facosh - fasinh - ftanh - fatanh - facos - fpow - fatan - fatan2 - fcos - ftan - fsin - fsqrt -} [ - dup stack-effect - [ in>> length real "input-classes" set-word-prop ] - [ out>> length float "default-output-classes" set-word-prop ] - 2bi -] each - : ?change-interval ( info quot -- quot' ) over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline @@ -169,10 +144,9 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -generic-comparison-ops [ - dup specific-comparison - '[ _ _ define-comparison-constraints ] each-derived-op -] each +! generic-comparison-ops [ +! dup specific-comparison define-comparison-constraints +! ] each ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) @@ -220,10 +194,22 @@ generic-comparison-ops [ 2bi and maybe-or-never ] "outputs" set-word-prop +\ both-fixnums? [ + [ class>> fixnum classes-intersect? not ] either? + f object-info ? +] "outputs" set-word-prop + { { >fixnum fixnum } + { bignum>fixnum fixnum } + { >bignum bignum } + { fixnum>bignum bignum } + { float>bignum bignum } + { >float float } + { fixnum>float float } + { bignum>float float } } [ '[ _ @@ -261,6 +247,10 @@ generic-comparison-ops [ ] "custom-inlining" set-word-prop ] each +\ string-nth [ + 2drop fixnum 0 23 2^ [a,b] +] "outputs" set-word-prop + { alien-signed-1 alien-unsigned-1 @@ -302,6 +292,15 @@ generic-comparison-ops [ "outputs" set-word-prop ] each +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop hashtable new ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index 9e4d99e462..d676102bde 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -6,6 +6,8 @@ compiler.tree.propagation.copy compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes +SYMBOL: loop-nesting + GENERIC: propagate-before ( node -- ) GENERIC: propagate-after ( node -- ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 760ff167aa..aa04b58de7 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -8,7 +8,8 @@ math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals -float-arrays system sorting ; +specialized-arrays.double system sorting math.libm +math.intervals ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -167,7 +168,8 @@ IN: compiler.tree.propagation.tests [ V{ fixnum } ] [ [ - [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth + { fixnum byte-array } declare + [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift 255 min 0 max ] final-classes @@ -434,7 +436,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test : recursive-test-4 ( i n -- ) - 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive + 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive [ ] [ [ recursive-test-4 ] final-info drop ] unit-test @@ -588,12 +590,20 @@ MIXIN: empty-mixin [ { fixnum integer } declare bitand ] final-classes ] unit-test -[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test +[ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test [ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test +[ V{ float } ] [ [ fsqrt ] final-classes ] unit-test + +[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test + +[ T{ interval f { 0 t } { 127 t } } ] [ + [ { integer } declare 127 bitand ] final-info first interval>> +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index b9822d2c6b..2a9825e3f1 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -19,5 +19,6 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set + H{ } clone inlining-count set dup count-nodes dup (propagate) ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 7f10f87016..ff9f262d28 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive M: #recursive propagate-around ( #recursive -- ) constraints [ H{ } clone suffix ] change [ + loop-nesting inc + constraints [ but-last H{ } clone suffix ] change child>> @@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- ) [ first propagate-recursive-phi ] [ (propagate) ] tri + + loop-nesting dec ] until-fixed-point ; : recursive-phi-infos ( node -- infos ) diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index d586ff398f..9937c6b9c4 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators classes classes.tuple -classes.tuple.private continuations arrays +classes.tuple.private continuations arrays alien.c-types math math.private slots generic definitions stack-checker.state compiler.tree @@ -137,11 +137,12 @@ M: #call propagate-after dup word>> "input-classes" word-prop dup [ propagate-input-classes ] [ 2drop ] if ; -M: #alien-invoke propagate-before - out-d>> [ object-info swap set-value-info ] each ; +: propagate-alien-invoke ( node -- ) + [ out-d>> ] [ params>> return>> ] bi + [ drop ] [ c-type-class swap first set-value-info ] if-void ; -M: #alien-indirect propagate-before - out-d>> [ object-info swap set-value-info ] each ; +M: #alien-invoke propagate-before propagate-alien-invoke ; -M: #return annotate-node - dup in-d>> (annotate-node) ; +M: #alien-indirect propagate-before propagate-alien-invoke ; + +M: #return annotate-node dup in-d>> (annotate-node) ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 52903fce8d..f6726e4404 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs accessors kernel combinators -classes.algebra sequences sequences.deep slots.private +classes.algebra sequences slots.private fry vectors classes.tuple.private math math.private arrays stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes ) : (expand-#push) ( object value -- nodes ) dup unboxed-allocation dup [ [ object-slots ] [ drop ] [ ] tri* - [ (expand-#push) ] 2map + [ (expand-#push) ] 2map-flat ] [ drop #push ] if ; @@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ drop { } ] when ; -: (flatten-values) ( values -- values' ) - [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; +: (flatten-values) ( values accum -- ) + dup '[ + dup unboxed-allocation + [ _ (flatten-values) ] [ _ push ] ?if + ] each ; : flatten-values ( values -- values' ) - dup empty? [ (flatten-values) flatten ] unless ; + dup empty? [ + 10 [ (flatten-values) ] keep + ] unless ; : prepare-slot-access ( #call -- tuple-values outputs slot-values ) [ in-d>> flatten-values ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor new file mode 100644 index 0000000000..1f488b3dde --- /dev/null +++ b/basis/compiler/utilities/utilities.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private arrays vectors fry +math.order ; +IN: compiler.utilities + +: flattener ( seq quot -- seq vector quot' ) + over length [ + dup + '[ + @ [ + dup array? + [ _ push-all ] [ _ push ] if + ] when* + ] + ] keep ; inline + +: flattening ( seq quot combinator -- seq' ) + [ flattener ] dip dip { } like ; inline + +: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline + +: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline + +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ [ [ length ] tri@ min min ] 3keep ] dip + '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline + +: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 43374d3127..11e624110c 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: deques threads kernel arrays sequences alarms ; +USING: deques threads kernel arrays sequences alarms fry ; IN: concurrency.conditions : notify-1 ( deque -- ) @@ -12,15 +12,18 @@ IN: concurrency.conditions : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the #! queue, and resumes it, passing it a value of t. - >r [ self swap push-front* ] keep [ - [ delete-node ] [ drop node-value ] 2bi - t swap resume-with - ] 2curry r> later ; + [ + [ self swap push-front* ] keep '[ + _ _ + [ delete-node ] [ drop node-value ] 2bi + t swap resume-with + ] + ] dip later ; : wait ( queue timeout status -- ) over [ - >r queue-timeout [ drop ] r> suspend + [ queue-timeout [ drop ] ] dip suspend [ "Timeout" throw ] [ cancel-alarm ] if ] [ - >r drop [ push-front ] curry r> suspend drop + [ drop '[ _ push-front ] ] dip suspend drop ] if ; diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index c4bc92c688..d79cfbf1c9 100644 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: dlists kernel math concurrency.promises -concurrency.mailboxes debugger accessors ; +concurrency.mailboxes debugger accessors fry ; IN: concurrency.count-downs ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html @@ -26,12 +26,12 @@ ERROR: count-down-already-done ; [ 1- >>n count-down-check ] if ; : await-timeout ( count-down timeout -- ) - >r promise>> r> ?promise-timeout ?linked t assert= ; + [ promise>> ] dip ?promise-timeout ?linked t assert= ; : await ( count-down -- ) f await-timeout ; : spawn-stage ( quot count-down -- ) - [ [ count-down ] curry compose ] keep + [ '[ @ _ count-down ] ] keep "Count down stage" swap promise>> mailbox>> spawn-linked-to drop ; diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 528e1956b8..1087823aa0 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -15,7 +15,7 @@ concurrency.messaging continuations accessors prettyprint ; [ ] [ [ - receive first2 >r 3 + r> send + receive first2 [ 3 + ] dip send "thread-a" unregister-process ] "Thread A" spawn "thread-a" swap register-process diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor index 6b44886eda..97b3c14fe4 100644 --- a/basis/concurrency/exchangers/exchangers.factor +++ b/basis/concurrency/exchangers/exchangers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads boxes accessors ; +USING: kernel threads boxes accessors fry ; IN: concurrency.exchangers ! Motivated by @@ -14,8 +14,8 @@ TUPLE: exchanger thread object ; : exchange ( obj exchanger -- newobj ) dup thread>> occupied>> [ dup object>> box> - >r thread>> box> resume-with r> + [ thread>> box> resume-with ] dip ] [ [ object>> >box ] keep - [ thread>> >box ] curry "exchange" suspend + '[ _ thread>> >box ] "exchange" suspend ] if ; diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 0f78183aba..a666293316 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -2,7 +2,7 @@ IN: concurrency.flags.tests USING: tools.test concurrency.flags concurrency.combinators kernel threads locals accessors calendar ; -:: flag-test-1 ( -- ) +:: flag-test-1 ( -- val ) [let | f [ ] | [ f raise-flag ] "Flag test" spawn drop f lower-flag @@ -20,7 +20,7 @@ kernel threads locals accessors calendar ; [ f ] [ flag-test-2 ] unit-test -:: flag-test-3 ( -- ) +:: flag-test-3 ( -- val ) [let | f [ ] | f raise-flag f value>> @@ -28,7 +28,7 @@ kernel threads locals accessors calendar ; [ t ] [ flag-test-3 ] unit-test -:: flag-test-4 ( -- ) +:: flag-test-4 ( -- val ) [let | f [ ] | [ f raise-flag ] "Flag test" spawn drop f wait-for-flag @@ -37,7 +37,7 @@ kernel threads locals accessors calendar ; [ t ] [ flag-test-4 ] unit-test -:: flag-test-5 ( -- ) +:: flag-test-5 ( -- val ) [let | f [ ] | [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop f wait-for-flag diff --git a/basis/concurrency/flags/flags.factor b/basis/concurrency/flags/flags.factor index ec260961d0..c65171a3f0 100644 --- a/basis/concurrency/flags/flags.factor +++ b/basis/concurrency/flags/flags.factor @@ -11,7 +11,7 @@ TUPLE: flag value threads ; dup value>> [ drop ] [ t >>value threads>> notify-all ] if ; : wait-for-flag-timeout ( flag timeout -- ) - over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ; + over value>> [ 2drop ] [ [ threads>> ] dip "flag" wait ] if ; : wait-for-flag ( flag -- ) f wait-for-flag-timeout ; diff --git a/basis/concurrency/futures/futures.factor b/basis/concurrency/futures/futures.factor index 132342aff1..a1f4f57af6 100644 --- a/basis/concurrency/futures/futures.factor +++ b/basis/concurrency/futures/futures.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises concurrency.mailboxes kernel arrays -continuations accessors ; +continuations accessors fry ; IN: concurrency.futures : future ( quot -- future ) [ - [ [ >r call r> fulfill ] 2curry "Future" ] keep + [ '[ @ _ fulfill ] "Future" ] keep mailbox>> spawn-linked-to drop ] keep ; inline diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 7696e6c1eb..8f82aa88ba 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar accessors ; -:: lock-test-0 ( -- ) +:: lock-test-0 ( -- v ) [let | v [ V{ } clone ] c [ 2 ] | @@ -27,7 +27,7 @@ threads sequences calendar accessors ; v ] ; -:: lock-test-1 ( -- ) +:: lock-test-1 ( -- v ) [let | v [ V{ } clone ] l [ ] c [ 2 ] | @@ -79,7 +79,7 @@ threads sequences calendar accessors ; [ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test -:: rw-lock-test-1 ( -- ) +:: rw-lock-test-1 ( -- v ) [let | l [ ] c [ 1 ] c' [ 1 ] @@ -129,7 +129,7 @@ threads sequences calendar accessors ; [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test -:: rw-lock-test-2 ( -- ) +:: rw-lock-test-2 ( -- v ) [let | l [ ] c [ 1 ] c' [ 2 ] @@ -160,7 +160,7 @@ threads sequences calendar accessors ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test ! Test lock timeouts -:: lock-timeout-test ( -- ) +:: lock-timeout-test ( -- v ) [let | l [ ] | [ l [ 1 seconds sleep ] with-lock @@ -177,19 +177,6 @@ threads sequences calendar accessors ; thread>> name>> "Lock timeout-er" = ] must-fail-with -:: read/write-test ( -- ) - [let | l [ ] | - [ - l [ 1 seconds sleep ] with-lock - ] "Lock holder" spawn drop - - [ - l 1/10 seconds [ ] with-lock-timeout - ] "Lock timeout-er" spawn-linked drop - - receive - ] ; - [ dup [ 1 seconds [ ] with-write-lock-timeout diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 8c1392dbfb..0094f3323d 100644 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: deques dlists kernel threads continuations math -concurrency.conditions combinators.short-circuit accessors ; +concurrency.conditions combinators.short-circuit accessors +locals ; IN: concurrency.locks ! Simple critical sections @@ -17,16 +18,16 @@ TUPLE: lock threads owner reentrant? ; : acquire-lock ( lock timeout -- ) over owner>> - [ 2dup >r threads>> r> "lock" wait ] when drop + [ 2dup [ threads>> ] dip "lock" wait ] when drop self >>owner drop ; : release-lock ( lock -- ) f >>owner threads>> notify-1 ; -: do-lock ( lock timeout quot acquire release -- ) - >r >r pick rot r> call ! use up timeout acquire - swap r> curry [ ] cleanup ; inline +:: do-lock ( lock timeout quot acquire release -- ) + lock timeout acquire call + quot lock release curry [ ] cleanup ; inline : (with-lock) ( lock timeout quot -- ) [ acquire-lock ] [ release-lock ] do-lock ; inline @@ -60,7 +61,7 @@ TUPLE: rw-lock readers writers reader# writer ; : acquire-read-lock ( lock timeout -- ) over writer>> - [ 2dup >r readers>> r> "read lock" wait ] when drop + [ 2dup [ readers>> ] dip "read lock" wait ] when drop add-reader ; : notify-writer ( lock -- ) @@ -75,7 +76,7 @@ TUPLE: rw-lock readers writers reader# writer ; : acquire-write-lock ( lock timeout -- ) over writer>> pick reader#>> 0 > or - [ 2dup >r writers>> r> "write lock" wait ] when drop + [ 2dup [ writers>> ] dip "write lock" wait ] when drop self >>writer drop ; : release-write-lock ( lock -- ) diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 39b21e0943..63707041a2 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -4,7 +4,7 @@ IN: concurrency.mailboxes USING: dlists deques threads sequences continuations destructors namespaces math quotations words kernel arrays assocs init system concurrency.conditions accessors -debugger debugger.threads locals ; +debugger debugger.threads locals fry ; TUPLE: mailbox threads data disposed ; @@ -21,7 +21,7 @@ M: mailbox dispose* threads>> notify-all ; [ threads>> notify-all ] bi yield ; : wait-for-mailbox ( mailbox timeout -- ) - >r threads>> r> "mailbox" wait ; + [ threads>> ] dip "mailbox" wait ; :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) mailbox check-disposed @@ -57,11 +57,11 @@ M: mailbox dispose* threads>> notify-all ; f mailbox-get-all-timeout ; : while-mailbox-empty ( mailbox quot -- ) - [ [ mailbox-empty? ] curry ] dip [ ] while ; inline + [ '[ _ mailbox-empty? ] ] dip [ ] while ; inline : mailbox-get-timeout? ( mailbox timeout pred -- obj ) [ block-unless-pred ] - [ nip >r data>> r> delete-node-if ] + [ [ drop data>> ] dip delete-node-if ] 3bi ; inline : mailbox-get? ( mailbox pred -- obj ) @@ -90,7 +90,7 @@ M: linked-thread error-in-thread [ ] [ supervisor>> ] bi mailbox-put ; : ( quot name mailbox -- thread' ) - >r linked-thread new-thread r> >>supervisor ; + [ linked-thread new-thread ] dip >>supervisor ; : spawn-linked-to ( quot name mailbox -- thread ) [ (spawn) ] keep ; diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 6c9e530d9b..3bd2d330c3 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -8,20 +8,20 @@ HELP: send { $values { "message" object } { "thread" thread } } -{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } +{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } { $see-also receive receive-if } ; HELP: receive { $values { "message" object } } -{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } +{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } { $see-also send receive-if } ; HELP: receive-if { $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } } { "message" object } } -{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } +{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } { $see-also send receive } ; HELP: spawn-linked @@ -29,7 +29,7 @@ HELP: spawn-linked { "name" string } { "thread" thread } } -{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } +{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" } { $see-also spawn } ; ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages" @@ -55,7 +55,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" { $example "USING: concurrency.messaging kernel threads ;" ": pong-server ( -- )" - " receive >r \"pong\" r> reply-synchronous ;" + " receive [ \"pong\" ] dip reply-synchronous ;" "[ pong-server t ] \"pong-server\" spawn-server" "\"ping\" swap send-synchronous ." "\"pong\"" @@ -64,7 +64,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } -"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." +"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them." { $subsection spawn-linked } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" @@ -74,11 +74,11 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: "concurrency.messaging" "Message-passing concurrency" -"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system." +"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "." $nl -"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." +"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends." $nl -"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." +"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." { $subsection { "concurrency" "messaging" } } { $subsection { "concurrency" "synchronous-sends" } } { $subsection { "concurrency" "exceptions" } } ; diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 9aeb24ed72..7a00f62e9e 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -! -! Concurrency library for Factor, based on Erlang/Termite style -! concurrency. USING: kernel threads concurrency.mailboxes continuations -namespaces assocs accessors summary ; +namespaces assocs accessors summary fry ; IN: concurrency.messaging GENERIC: send ( message thread -- ) @@ -32,7 +29,7 @@ M: thread send ( message thread -- ) my-mailbox -rot mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) - >r r> send ; + [ ] dip send ; : spawn-linked ( quot name -- thread ) my-mailbox spawn-linked-to ; @@ -48,9 +45,7 @@ TUPLE: reply data tag ; tag>> \ reply boa ; : synchronous-reply? ( response synchronous -- ? ) - over reply? - [ >r tag>> r> tag>> = ] - [ 2drop f ] if ; + over reply? [ [ tag>> ] bi@ = ] [ 2drop f ] if ; ERROR: cannot-send-synchronous-to-self message thread ; @@ -61,8 +56,8 @@ M: cannot-send-synchronous-to-self summary dup self eq? [ cannot-send-synchronous-to-self ] [ - >r dup r> send - [ synchronous-reply? ] curry receive-if + [ dup ] dip send + '[ _ synchronous-reply? ] receive-if data>> ] if ; diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor index 382697e04f..2ff338c4e3 100644 --- a/basis/concurrency/promises/promises.factor +++ b/basis/concurrency/promises/promises.factor @@ -20,7 +20,7 @@ ERROR: promise-already-fulfilled promise ; ] if ; : ?promise-timeout ( promise timeout -- result ) - >r mailbox>> r> block-if-empty mailbox-peek ; + [ mailbox>> ] dip block-if-empty mailbox-peek ; : ?promise ( promise -- result ) f ?promise-timeout ; diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor index 1b55c7afa5..59518f4c8d 100644 --- a/basis/concurrency/semaphores/semaphores.factor +++ b/basis/concurrency/semaphores/semaphores.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: dlists kernel threads math concurrency.conditions -continuations accessors summary ; +continuations accessors summary locals fry ; IN: concurrency.semaphores TUPLE: semaphore count threads ; @@ -30,9 +30,9 @@ M: negative-count-semaphore summary [ 1+ ] change-count threads>> notify-1 ; -: with-semaphore-timeout ( semaphore timeout quot -- ) - pick rot acquire-timeout swap - [ release ] curry [ ] cleanup ; inline +:: with-semaphore-timeout ( semaphore timeout quot -- ) + semaphore timeout acquire-timeout + quot [ semaphore release ] [ ] cleanup ; inline : with-semaphore ( semaphore quot -- ) - over acquire swap [ release ] curry [ ] cleanup ; inline + swap dup acquire '[ _ release ] [ ] cleanup ; inline diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 00bf73e9dd..d63a66dbe7 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef TYPEDEF: void* CFURLRef TYPEDEF: void* CFUUIDRef TYPEDEF: void* CFTypeRef +TYPEDEF: void* CFFileDescriptorRef TYPEDEF: bool Boolean TYPEDEF: long CFIndex TYPEDEF: int SInt32 TYPEDEF: uint UInt32 TYPEDEF: ulong CFTypeID +TYPEDEF: UInt32 CFOptionFlags TYPEDEF: double CFTimeInterval TYPEDEF: double CFAbsoluteTime +TYPEDEF: int CFFileDescriptorNativeDescriptor +TYPEDEF: void* CFFileDescriptorCallBack TYPEDEF: int CFNumberType : kCFNumberSInt8Type 1 ; inline @@ -90,25 +94,25 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; : ( seq -- alien ) [ f swap length f CFArrayCreateMutable ] keep [ length ] keep - [ >r dupd r> CFArraySetValueAtIndex ] 2each ; + [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ; : ( string -- alien ) f swap dup length CFStringCreateWithCharacters ; : CF>string ( alien -- string ) dup CFStringGetLength 1+ "ushort" [ - >r 0 over CFStringGetLength r> CFStringGetCharacters + [ 0 over CFStringGetLength ] dip CFStringGetCharacters ] keep utf16n alien>string ; : CF>string-array ( alien -- seq ) CF>array [ CF>string ] map ; : ( seq -- alien ) - [ ] map dup swap [ CFRelease ] each ; + [ ] map [ ] [ [ CFRelease ] each ] bi ; : ( string dir? -- url ) - >r f over kCFURLPOSIXPathStyle - r> CFURLCreateWithFileSystemPath swap CFRelease ; + [ f over kCFURLPOSIXPathStyle ] dip + CFURLCreateWithFileSystemPath swap CFRelease ; : ( string -- url ) @@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; ] keep CFRelease ; GENERIC: ( number -- alien ) + M: integer [ f kCFNumberLongLongType ] dip CFNumberCreate ; + M: float [ f kCFNumberDoubleType ] dip CFNumberCreate ; + M: t drop f kCFNumberIntType 1 CFNumberCreate ; + M: f drop f kCFNumberIntType 0 CFNumberCreate ; : ( byte-array -- alien ) [ f ] dip dup length CFDataCreate ; +FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( + CFAllocatorRef allocator, + CFFileDescriptorNativeDescriptor fd, + Boolean closeOnInvalidate, + CFFileDescriptorCallBack callout, + CFFileDescriptorContext* context +) ; + +FUNCTION: void CFFileDescriptorEnableCallBacks ( + CFFileDescriptorRef f, + CFOptionFlags callBackTypes +) ; + : load-framework ( name -- ) dup [ CFBundleLoadExecutable drop @@ -141,8 +162,11 @@ M: f ] ?if ; TUPLE: CFRelease-destructor alien disposed ; + M: CFRelease-destructor dispose* alien>> CFRelease ; + : &CFRelease ( alien -- alien ) dup f CFRelease-destructor boa &dispose drop ; inline + : |CFRelease ( alien -- alien ) dup f CFRelease-destructor boa |dispose drop ; inline diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 6bec4b23c0..d4d5e88512 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -4,7 +4,9 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators core-foundation core-foundation.run-loop core-foundation.run-loop.thread -io.encodings.utf8 destructors ; +io.encodings.utf8 destructors locals arrays +specialized-arrays.direct.alien specialized-arrays.direct.int +specialized-arrays.direct.longlong ; IN: core-foundation.fsevents : kFSEventStreamCreateFlagUseCFTypes 2 ; inline @@ -105,15 +107,14 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef "FSEventStreamContext" [ set-FSEventStreamContext-info ] keep ; -: ( callback info paths latency flags -- event-stream ) - >r >r >r >r >r +:: ( callback info paths latency flags -- event-stream ) f ! allocator - r> ! callback - r> make-FSEventStreamContext - r> ! paths + callback + info make-FSEventStreamContext + paths FSEventStreamEventIdSinceNow ! sinceWhen - r> ! latency - r> ! flags + latency + flags FSEventStreamCreate ; : kCFRunLoopCommonModes ( -- string ) @@ -161,13 +162,12 @@ SYMBOL: event-stream-callbacks : remove-event-source-callback ( id -- ) event-stream-callbacks get delete-at ; -: >event-triple ( n eventPaths eventFlags eventIds -- triple ) - [ - >r >r >r dup dup - r> void*-nth utf8 alien>string , - r> int-nth , - r> longlong-nth , - ] { } make ; +:: (master-event-source-callback) ( eventStream info numEvents eventPaths eventFlags eventIds -- ) + eventPaths numEvents [ utf8 alien>string ] { } map-as + eventFlags numEvents + eventIds numEvents + 3array flip + info event-stream-callbacks get at [ drop ] or call ; : master-event-source-callback ( -- alien ) "void" @@ -179,19 +179,15 @@ SYMBOL: event-stream-callbacks "FSEventStreamEventFlags*" "FSEventStreamEventId*" } - "cdecl" [ - [ >event-triple ] 3curry map - swap event-stream-callbacks get at - dup [ call drop ] [ 3drop ] if - ] alien-callback ; + "cdecl" [ (master-event-source-callback) ] alien-callback ; TUPLE: event-stream info handle disposed ; : ( quot paths latency flags -- event-stream ) - >r >r >r - add-event-source-callback dup - >r master-event-source-callback r> - r> r> r> + [ + add-event-source-callback dup + [ master-event-source-callback ] dip + ] 3dip dup enable-event-stream f event-stream boa ; diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 9a5666b5d3..c334297122 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -10,6 +10,7 @@ IN: core-foundation.run-loop : kCFRunLoopRunHandledSource 4 ; inline TYPEDEF: void* CFRunLoopRef +TYPEDEF: void* CFRunLoopSourceRef FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ; @@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode ( Boolean returnAfterSourceHandled ) ; +FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource ( + CFAllocatorRef allocator, + CFFileDescriptorRef f, + CFIndex order +) ; + +FUNCTION: void CFRunLoopAddSource ( + CFRunLoopRef rl, + CFRunLoopSourceRef source, + CFStringRef mode +) ; + : CFRunLoopDefaultMode ( -- alien ) #! Ugly, but we don't have static NSStrings \ CFRunLoopDefaultMode get-global dup expired? [ diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d26e7f6ff7..c609b9e98d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -59,6 +59,7 @@ HOOK: %set-slot cpu ( src obj slot tag temp -- ) HOOK: %set-slot-imm cpu ( src obj slot tag -- ) HOOK: %string-nth cpu ( dst obj index temp -- ) +HOOK: %set-string-nth-fast cpu ( ch obj index temp -- ) HOOK: %add cpu ( dst src1 src2 -- ) HOOK: %add-imm cpu ( dst src1 src2 -- ) @@ -76,6 +77,14 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- ) HOOK: %shr-imm cpu ( dst src1 src2 -- ) HOOK: %sar-imm cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) +HOOK: %log2 cpu ( dst src -- ) + +HOOK: %fixnum-add cpu ( src1 src2 -- ) +HOOK: %fixnum-add-tail cpu ( src1 src2 -- ) +HOOK: %fixnum-sub cpu ( src1 src2 -- ) +HOOK: %fixnum-sub-tail cpu ( src1 src2 -- ) +HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- ) +HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- ) HOOK: %integer>bignum cpu ( dst src temp -- ) HOOK: %bignum>integer cpu ( dst src temp -- ) @@ -112,6 +121,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- ) HOOK: %set-alien-float cpu ( ptr value -- ) HOOK: %set-alien-double cpu ( ptr value -- ) +HOOK: %alien-global cpu ( dst symbol library -- ) + HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %gc cpu ( -- ) @@ -119,9 +130,9 @@ HOOK: %gc cpu ( -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) -HOOK: %compare cpu ( dst cc src1 src2 -- ) -HOOK: %compare-imm cpu ( dst cc src1 src2 -- ) -HOOK: %compare-float cpu ( dst cc src1 src2 -- ) +HOOK: %compare cpu ( dst temp cc src1 src2 -- ) +HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- ) +HOOK: %compare-float cpu ( dst temp cc src1 src2 -- ) HOOK: %compare-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 56ef89884c..445c7082bc 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -24,7 +24,6 @@ big-endian on [ 0 6 LOAD32 - 6 dup 0 LWZ 11 6 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI 11 6 profile-count-offset STW @@ -32,7 +31,7 @@ big-endian on 11 11 compiled-header-size ADDI 11 MTCTR BCTR -] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define +] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define [ 0 6 LOAD32 @@ -44,12 +43,6 @@ big-endian on 0 1 lr-save stack-frame + STW ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define -[ - 0 6 LOAD32 - 6 dup 0 LWZ - 6 ds-reg 4 STWU -] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define - [ 0 6 LOAD32 6 ds-reg 4 STWU @@ -71,40 +64,32 @@ big-endian on [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define +[ + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 0 3 \ f tag-number CMPI + 2 BEQ + 0 B +] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define + +[ + 0 B +] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define + : jit-jump-quot ( -- ) 4 3 quot-xt-offset LWZ 4 MTCTR BCTR ; -: jit-call-quot ( -- ) - 4 3 quot-xt-offset LWZ - 4 MTLR - BLR ; - [ 0 3 LOAD32 6 ds-reg 0 LWZ - 0 6 \ f tag-number CMPI - 2 BNE - 3 3 4 ADDI - 3 3 0 LWZ - ds-reg dup 4 SUBI - jit-jump-quot -] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define - -[ - 0 3 LOAD32 - 3 3 0 LWZ - 6 ds-reg 0 LWZ 6 6 1 SRAWI 3 3 6 ADD 3 3 array-start-offset LWZ ds-reg dup 4 SUBI jit-jump-quot -] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define - -! These should not clobber r3 since we store a quotation in there -! in jit-dip +] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -130,9 +115,9 @@ big-endian on 6 rs-reg -8 STW ; : jit-r> ( -- ) - 4 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 rs-reg 4 STWU ; + 4 rs-reg 0 LWZ + rs-reg dup 4 SUBI + 4 ds-reg 4 STWU ; : jit-2r> ( -- ) 4 rs-reg 0 LWZ @@ -152,30 +137,23 @@ big-endian on 5 ds-reg -4 STW 6 ds-reg -8 STW ; -: prepare-dip ( -- ) - 0 3 LOAD32 - 3 3 0 LWZ ; - [ - prepare-dip jit->r - jit-call-quot + 0 BL jit-r> -] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define +] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define [ - prepare-dip jit-2>r - jit-call-quot + 0 BL jit-2r> -] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define +] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define [ - prepare-dip jit-3>r - jit-call-quot + 0 BL jit-3r> -] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define +] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define [ 0 1 lr-save stack-frame + LWZ @@ -331,7 +309,6 @@ big-endian on ! Comparisons : jit-compare ( insn -- ) 0 3 LOAD32 - 3 3 0 LWZ 4 ds-reg 0 LWZ 5 ds-reg -4 LWZU 5 0 4 CMP @@ -340,7 +317,7 @@ big-endian on 3 ds-reg 0 STW ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip + [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip define-sub-primitive ; \ BEQ \ eq? define-jit-compare @@ -350,6 +327,19 @@ big-endian on \ BLT \ fixnum< define-jit-compare ! Math +[ + 3 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + 4 ds-reg 0 LWZ + 3 3 4 OR + 3 3 tag-mask get ANDI + \ f tag-number 4 LI + 0 3 0 CMPI + 2 BNE + 1 tag-fixnum 4 LI + 4 ds-reg 0 STW +] f f f \ both-fixnums? define-sub-primitive + : jit-math ( insn -- ) 3 ds-reg 0 LWZ 4 ds-reg -4 LWZU @@ -411,6 +401,7 @@ big-endian on ds-reg ds-reg 4 SUBI 4 ds-reg 0 LWZ 5 4 3 DIVW + 5 5 tag-bits get SLWI 5 ds-reg 0 STW ] f f f \ fixnum/i-fast define-sub-primitive @@ -420,6 +411,7 @@ big-endian on 5 4 3 DIVW 6 5 3 MULLW 7 6 4 SUBF + 5 5 tag-bits get SLWI 5 ds-reg -4 STW 7 ds-reg 0 STW ] f f f \ fixnum/mod-fast define-sub-primitive @@ -427,9 +419,7 @@ big-endian on [ 3 ds-reg 0 LWZ 3 3 1 SRAWI - 4 4 LI - 4 3 4 SUBF - rs-reg 3 4 LWZX + rs-reg 3 3 LWZX 3 ds-reg 0 STW ] f f f \ get-local define-sub-primitive diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index c656ae4d89..c555c4b809 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -34,10 +34,11 @@ M: ppc two-operand? f ; M: ppc %load-immediate ( reg n -- ) swap LOAD ; -M:: ppc %load-indirect ( reg obj -- ) - 0 reg LOAD32 - obj rc-absolute-ppc-2/2 rel-literal - reg reg 0 LWZ ; +M: ppc %load-indirect ( reg obj -- ) + [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ; + +M: ppc %alien-global ( register symbol dll -- ) + [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; : ds-reg 29 ; inline : rs-reg 30 ; inline @@ -138,17 +139,21 @@ M:: ppc %string-nth ( dst src index temp -- ) "end" define-label temp src index ADD dst temp string-offset LBZ + 0 dst HEX: 80 CMPI + "end" get BLT temp src string-aux-offset LWZ - 0 temp \ f tag-number CMPI - "end" get BEQ temp temp index ADD temp temp index ADD temp temp byte-array-offset LHZ - temp temp 8 SLWI - dst dst temp OR + temp temp 7 SLWI + dst dst temp XOR "end" resolve-label ] with-scope ; +M:: ppc %set-string-nth-fast ( ch obj index temp -- ) + temp obj index ADD + ch temp string-offset STB ; + M: ppc %add ADD ; M: ppc %add-imm ADDI ; M: ppc %sub swap SUBF ; @@ -166,6 +171,91 @@ M: ppc %shr-imm swapd SRWI ; M: ppc %sar-imm SRAWI ; M: ppc %not NOT ; +: %alien-invoke-tail ( func dll -- ) + [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ; + +:: exchange-regs ( r1 r2 -- ) + scratch-reg r1 MR + r1 r2 MR + r2 scratch-reg MR ; + +: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ; + +:: move>args ( src1 src2 -- ) + { + { [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] } + { [ src1 3 = ] [ 4 src2 ?MR ] } + { [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] } + { [ src2 4 = ] [ 3 src1 ?MR ] } + [ 3 src1 MR 4 src2 MR ] + } cond ; + +: clear-xer ( -- ) + 0 0 LI + 0 MTXER ; inline + +:: overflow-template ( src1 src2 insn func -- ) + "no-overflow" define-label + clear-xer + scratch-reg src2 src1 insn call + scratch-reg ds-reg 0 STW + "no-overflow" get BNO + src1 src2 move>args + %prepare-alien-invoke + func f %alien-invoke + "no-overflow" resolve-label ; inline + +:: overflow-template-tail ( src1 src2 insn func -- ) + "overflow" define-label + clear-xer + scratch-reg src2 src1 insn call + "overflow" get BO + scratch-reg ds-reg 0 STW + BLR + "overflow" resolve-label + src1 src2 move>args + %prepare-alien-invoke + func f %alien-invoke-tail ; inline + +M: ppc %fixnum-add ( src1 src2 -- ) + [ ADDO. ] "overflow_fixnum_add" overflow-template ; + +M: ppc %fixnum-add-tail ( src1 src2 -- ) + [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ; + +M: ppc %fixnum-sub ( src1 src2 -- ) + [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ; + +M: ppc %fixnum-sub-tail ( src1 src2 -- ) + [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ; + +M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- ) + "no-overflow" define-label + clear-xer + temp1 src1 tag-bits get SRAWI + temp2 temp1 src2 MULLWO. + temp2 ds-reg 0 STW + "no-overflow" get BNO + src2 src2 tag-bits get SRAWI + temp1 src2 move>args + %prepare-alien-invoke + "overflow_fixnum_multiply" f %alien-invoke + "no-overflow" resolve-label ; + +M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- ) + "overflow" define-label + clear-xer + temp1 src1 tag-bits get SRAWI + temp2 temp1 src2 MULLWO. + "overflow" get BO + temp2 ds-reg 0 STW + BLR + "overflow" resolve-label + src2 src2 tag-bits get SRAWI + temp1 src2 move>args + %prepare-alien-invoke + "overflow_fixnum_multiply" f %alien-invoke-tail ; + : bignum@ ( n -- offset ) cells bignum tag-number - ; inline M:: ppc %integer>bignum ( dst src temp -- ) @@ -320,11 +410,8 @@ M: ppc %set-alien-cell swap 0 STW ; M: ppc %set-alien-float swap 0 STFS ; M: ppc %set-alien-double swap 0 STFD ; -: %load-dlsym ( symbol dll register -- ) - 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; - : load-zone-ptr ( reg -- ) - [ "nursery" f ] dip %load-dlsym ; + "nursery" f %alien-global ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ; @@ -346,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- ) dst class store-header dst class store-tagged ; -: %alien-global ( dst name -- ) - [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ; - : load-cards-offset ( dst -- ) - "cards_offset" %alien-global ; + [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ; : load-decks-offset ( dst -- ) - "decks_offset" %alien-global ; + [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ; M:: ppc %write-barrier ( src card# table -- ) card-mark scratch-reg LI @@ -398,14 +482,14 @@ M: ppc %epilogue ( n -- ) 1 1 rot ADDI 0 MTLR ; -:: (%boolean) ( dst word -- ) +:: (%boolean) ( dst temp word -- ) "end" define-label dst \ f tag-number %load-immediate "end" get word execute dst \ t %load-indirect "end" get resolve-label ; inline -: %boolean ( dst cc -- ) +: %boolean ( dst temp cc -- ) negate-cc { { cc< [ \ BLT (%boolean) ] } { cc<= [ \ BLE (%boolean) ] } @@ -540,14 +624,14 @@ M: ppc %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - "stack_chain" f 11 %load-dlsym - 11 11 0 LWZ - 1 11 0 STW - ds-reg 11 8 STW - rs-reg 11 12 STW ; + scratch-reg "stack_chain" f %alien-global + scratch-reg scratch-reg 0 LWZ + 1 scratch-reg 0 STW + ds-reg scratch-reg 8 STW + rs-reg scratch-reg 12 STW ; M: ppc %alien-invoke ( symbol dll -- ) - 11 %load-dlsym 11 MTLR BLRL ; + [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) 3 swap %load-indirect "c_to_factor" f %alien-invoke ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor old mode 100644 new mode 100755 index f892271fd5..5e06e72118 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -23,8 +23,8 @@ M: x86.32 machine-registers M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; -M: x86.32 temp-reg-1 EAX ; -M: x86.32 temp-reg-2 ECX ; +M: x86.32 temp-reg-1 ECX ; +M: x86.32 temp-reg-2 EDX ; M:: x86.32 %dispatch ( src temp offset -- ) ! Load jump table base. @@ -38,12 +38,16 @@ M:: x86.32 %dispatch ( src temp offset -- ) [ align-code ] bi ; +! Registers for fastcall +M: x86.32 param-reg-1 EAX ; +M: x86.32 param-reg-2 EDX ; + M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; - M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; + M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; @@ -88,8 +92,6 @@ M: float-regs store-return-reg [ [ align-sub ] [ call ] bi* ] [ [ align-add ] [ drop ] bi* ] 2bi ; inline -M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ; - M: x86.32 %prologue ( n -- ) dup PUSH 0 PUSH rc-absolute-cell rel-this @@ -303,7 +305,7 @@ FUNCTION: bool check_sse2 ( ) ; : sse2? ( -- ? ) check_sse2 ; -"-no-sse2" cli-args member? [ +"-no-sse2" (command-line) member? [ [ optimized-recompile-hook ] recompile-hook [ { check_sse2 } compile ] with-variable diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 75c808b50a..2077f51e0a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -21,8 +21,6 @@ M: x86.64 machine-registers M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; -M: x86.64 temp-reg-1 RAX ; -M: x86.64 temp-reg-2 RCX ; M:: x86.64 %dispatch ( src temp offset -- ) ! Load jump table base. @@ -37,15 +35,13 @@ M:: x86.64 %dispatch ( src temp offset -- ) [ align-code ] bi ; -: param-reg-1 int-regs param-regs first ; inline -: param-reg-2 int-regs param-regs second ; inline +M: x86.64 param-reg-1 int-regs param-regs first ; +M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-3 int-regs param-regs third ; inline M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; -M: x86.64 rel-literal-x86 rc-relative rel-literal ; - M: x86.64 %prologue ( n -- ) temp-reg-1 0 MOV rc-absolute-cell rel-this dup PUSH @@ -162,14 +158,16 @@ M: x86.64 %prepare-box-struct ( -- ) M: x86.64 %prepare-var-args RAX RAX XOR ; -M: x86.64 %alien-global - [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ; - M: x86.64 %alien-invoke R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ; +M: x86.64 %alien-invoke-tail + R11 0 MOV + rc-absolute-cell rel-dlsym + R11 JMP ; + M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke RBP RAX MOV ; diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index ddb412873a..f5fb5b9640 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -52,3 +52,7 @@ M: x86.64 dummy-stack-params? f ; M: x86.64 dummy-int-params? f ; M: x86.64 dummy-fp-params? f ; + +M: x86.64 temp-reg-1 R8 ; + +M: x86.64 temp-reg-2 R9 ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 9108c0e8f7..4c6af6c1e7 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -20,9 +20,13 @@ M: x86.64 dummy-int-params? t ; M: x86.64 dummy-fp-params? t ; +M: x86.64 temp-reg-1 RAX ; + +M: x86.64 temp-reg-2 RCX ; + << "longlong" "ptrdiff_t" typedef "longlong" "intptr_t" typedef -"int" "long" typedef -"uint" "ulong" typedef +"int" c-type "long" define-primitive-type +"uint" c-type "ulong" define-primitive-type >> diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 5c6fff2348..2bea887295 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -130,7 +130,7 @@ M: register modifier drop BIN: 11 ; GENERIC# n, 1 ( value n -- ) M: integer n, >le % ; -M: byte n, >r value>> r> n, ; +M: byte n, [ value>> ] dip n, ; : 1, ( n -- ) 1 n, ; inline : 4, ( n -- ) 4 n, ; inline : 2, ( n -- ) 2 n, ; inline @@ -209,7 +209,7 @@ M: object operand-64? drop f ; : short-operand ( reg rex.w n -- ) #! Some instructions encode their single operand as part of #! the opcode. - >r dupd prefix-1 reg-code r> + , ; + [ dupd prefix-1 reg-code ] dip + , ; : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ; @@ -224,7 +224,7 @@ M: object operand-64? drop f ; : 1-operand ( op reg,rex.w,opcode -- ) #! The 'reg' is not really a register, but a value for the #! 'reg' field of the mod-r/m byte. - first3 >r >r over r> prefix-1 r> opcode, swap addressing ; + first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ; : immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode ) pick integer? [ first3 BIN: 1 opcode-or 3array ] when ; @@ -250,7 +250,7 @@ M: object operand-64? drop f ; ] if ; : (2-operand) ( dst src op -- ) - >r 2dup t rex-prefix r> opcode, + [ 2dup t rex-prefix ] dip opcode, reg-code swap addressing ; : direction-bit ( dst src op -- dst' src' op' ) @@ -271,11 +271,11 @@ M: object operand-64? drop f ; PRIVATE> : [] ( reg/displacement -- indirect ) - dup integer? [ >r f f f r> ] [ f f f ] if ; + dup integer? [ [ f f f ] dip ] [ f f f ] if ; : [+] ( reg displacement -- indirect ) dup integer? - [ dup zero? [ drop f ] when >r f f r> ] + [ dup zero? [ drop f ] when [ f f ] dip ] [ f f ] if ; @@ -300,7 +300,7 @@ PREDICATE: callable < word register? not ; GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ; +M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; @@ -308,18 +308,21 @@ M: operand MOV HEX: 88 2-operand ; ! Control flow GENERIC: JMP ( op -- ) : (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; +M: f JMP (JMP) 2drop ; M: callable JMP (JMP) rel-word ; M: label JMP (JMP) label-fixup ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; +M: f CALL (CALL) 2drop ; M: callable CALL (CALL) rel-word ; M: label CALL (CALL) label-fixup ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) : (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ; +M: f JUMPcc nip (JUMPcc) drop ; M: callable JUMPcc (JUMPcc) rel-word ; M: label JUMPcc (JUMPcc) label-fixup ; @@ -381,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ; : XCHG ( dst src -- ) OCT: 207 2-operand ; +: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ; + : NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ; : NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ; : MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ; diff --git a/basis/cpu/x86/assembler/syntax/syntax.factor b/basis/cpu/x86/assembler/syntax/syntax.factor index d267baaf4f..6ddec4af07 100644 --- a/basis/cpu/x86/assembler/syntax/syntax.factor +++ b/basis/cpu/x86/assembler/syntax/syntax.factor @@ -4,8 +4,8 @@ USING: kernel words sequences lexer parser fry ; IN: cpu.x86.assembler.syntax : define-register ( name num size -- ) - >r >r "cpu.x86.assembler" create dup define-symbol r> r> - >r dupd "register" set-word-prop r> + [ "cpu.x86.assembler" create dup define-symbol ] 2dip + [ dupd "register" set-word-prop ] dip "register-size" set-word-prop ; : define-registers ( names size -- ) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index af7c9e2f0f..597a2c9d31 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -13,7 +13,6 @@ big-endian off [ ! Load word temp-reg 0 MOV - temp-reg dup [] MOV ! Bump profiling counter temp-reg profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code @@ -22,7 +21,7 @@ big-endian off temp-reg compiled-header-size ADD ! Jump to XT temp-reg JMP -] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define +] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define [ temp-reg 0 MOV ! load XT @@ -31,13 +30,6 @@ big-endian off stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define -[ - arg0 0 MOV ! load literal - arg0 dup [] MOV - ds-reg bootstrap-cell ADD ! increment datastack pointer - ds-reg [] arg0 MOV ! store literal on datastack -] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define - [ arg0 0 MOV ! load literal ds-reg bootstrap-cell ADD ! increment datastack pointer @@ -45,107 +37,99 @@ big-endian off ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define [ - (JMP) drop + f JMP ] rc-relative rt-xt 1 jit-word-jump jit-define [ - (CALL) drop + f CALL ] rc-relative rt-xt 1 jit-word-call jit-define [ - arg1 0 MOV ! load addr of true quotation arg0 ds-reg [] MOV ! load boolean ds-reg bootstrap-cell SUB ! pop boolean - arg0 \ f tag-number CMP ! compare it with f - arg0 arg1 [] CMOVNE ! load true branch if not equal - arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal - arg0 quot-xt-offset [+] JMP ! jump to quotation-xt -] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define + arg0 \ f tag-number CMP ! compare boolean with f + f JNE ! jump to true branch if not equal +] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define + +[ + f JMP ! jump to false branch if equal +] rc-relative rt-xt 1 jit-if-2 jit-define [ arg1 0 MOV ! load dispatch table - arg1 dup [] MOV arg0 ds-reg [] MOV ! load index fixnum>slot@ ! turn it into an array offset ds-reg bootstrap-cell SUB ! pop index arg0 arg1 ADD ! compute quotation location arg0 arg0 array-start-offset [+] MOV ! load quotation arg0 quot-xt-offset [+] JMP ! execute branch -] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define - -! The jit->r words cannot clobber arg0 +] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD - temp-reg ds-reg [] MOV + arg0 ds-reg [] MOV ds-reg bootstrap-cell SUB - rs-reg [] temp-reg MOV ; + rs-reg [] arg0 MOV ; : jit-2>r ( -- ) rs-reg 2 bootstrap-cells ADD - temp-reg ds-reg [] MOV + arg0 ds-reg [] MOV arg1 ds-reg -1 bootstrap-cells [+] MOV ds-reg 2 bootstrap-cells SUB - rs-reg [] temp-reg MOV + rs-reg [] arg0 MOV rs-reg -1 bootstrap-cells [+] arg1 MOV ; : jit-3>r ( -- ) rs-reg 3 bootstrap-cells ADD - temp-reg ds-reg [] MOV + arg0 ds-reg [] MOV arg1 ds-reg -1 bootstrap-cells [+] MOV arg2 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells SUB - rs-reg [] temp-reg MOV + rs-reg [] arg0 MOV rs-reg -1 bootstrap-cells [+] arg1 MOV rs-reg -2 bootstrap-cells [+] arg2 MOV ; : jit-r> ( -- ) ds-reg bootstrap-cell ADD - temp-reg rs-reg [] MOV + arg0 rs-reg [] MOV rs-reg bootstrap-cell SUB - ds-reg [] temp-reg MOV ; + ds-reg [] arg0 MOV ; : jit-2r> ( -- ) ds-reg 2 bootstrap-cells ADD - temp-reg rs-reg [] MOV + arg0 rs-reg [] MOV arg1 rs-reg -1 bootstrap-cells [+] MOV rs-reg 2 bootstrap-cells SUB - ds-reg [] temp-reg MOV + ds-reg [] arg0 MOV ds-reg -1 bootstrap-cells [+] arg1 MOV ; : jit-3r> ( -- ) ds-reg 3 bootstrap-cells ADD - temp-reg rs-reg [] MOV + arg0 rs-reg [] MOV arg1 rs-reg -1 bootstrap-cells [+] MOV arg2 rs-reg -2 bootstrap-cells [+] MOV rs-reg 3 bootstrap-cells SUB - ds-reg [] temp-reg MOV + ds-reg [] arg0 MOV ds-reg -1 bootstrap-cells [+] arg1 MOV ds-reg -2 bootstrap-cells [+] arg2 MOV ; [ - arg0 0 MOV ! load quotation addr - arg0 arg0 [] MOV ! load quotation jit->r - arg0 quot-xt-offset [+] CALL ! call quotation + f CALL jit-r> -] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define +] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define [ - arg0 0 MOV ! load quotation addr - arg0 arg0 [] MOV ! load quotation jit-2>r - arg0 quot-xt-offset [+] CALL ! call quotation + f CALL jit-2r> -] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define +] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define [ - arg0 0 MOV ! load quotation addr - arg0 arg0 [] MOV ! load quotation jit-3>r - arg0 quot-xt-offset [+] CALL ! call quotation + f CALL jit-3r> -] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define +] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame @@ -303,9 +287,8 @@ big-endian off ! Comparisons : jit-compare ( insn -- ) - arg1 0 MOV ! load t - arg1 dup [] MOV - temp-reg \ f tag-number MOV ! load f + temp-reg 0 MOV ! load t + arg1 \ f tag-number MOV ! load f arg0 ds-reg [] MOV ! load first value ds-reg bootstrap-cell SUB ! adjust stack pointer ds-reg [] arg0 CMP ! compare with second value @@ -314,14 +297,14 @@ big-endian off ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip + [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip define-sub-primitive ; -\ CMOVNE \ eq? define-jit-compare -\ CMOVL \ fixnum>= define-jit-compare -\ CMOVG \ fixnum<= define-jit-compare -\ CMOVLE \ fixnum> define-jit-compare -\ CMOVGE \ fixnum< define-jit-compare +\ CMOVE \ eq? define-jit-compare +\ CMOVGE \ fixnum>= define-jit-compare +\ CMOVLE \ fixnum<= define-jit-compare +\ CMOVG \ fixnum> define-jit-compare +\ CMOVL \ fixnum< define-jit-compare ! Math : jit-math ( insn -- ) @@ -396,12 +379,21 @@ big-endian off ds-reg bootstrap-cell neg [+] div-arg MOV ] f f f \ fixnum/mod-fast define-sub-primitive +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + arg0 ds-reg [] OR + arg0 tag-mask get AND + arg0 \ f tag-number MOV + arg1 1 tag-fixnum MOV + arg0 arg1 CMOVE + ds-reg [] arg0 MOV +] f f f \ both-fixnums? define-sub-primitive + [ arg0 ds-reg [] MOV ! load local number fixnum>slot@ ! turn local number into offset - arg1 bootstrap-cell MOV ! load base - arg1 arg0 SUB ! turn it into a stack offset - arg0 rs-reg arg1 [+] MOV ! load local value + arg0 rs-reg arg0 [+] MOV ! load local value ds-reg [] arg0 MOV ! push to stack ] f f f \ get-local define-sub-primitive diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 58d95ffcde..44300a75f9 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -5,20 +5,23 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private math memory namespaces make sequences words system layouts combinators math.order fry locals compiler.constants compiler.cfg.registers -compiler.cfg.instructions compiler.codegen -compiler.codegen.fixup ; +compiler.cfg.instructions compiler.cfg.intrinsics +compiler.codegen compiler.codegen.fixup ; IN: cpu.x86 +<< enable-fixnum-log2 >> + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) HOOK: temp-reg-2 cpu ( -- reg ) +HOOK: param-reg-1 cpu ( -- reg ) +HOOK: param-reg-2 cpu ( -- reg ) + M: x86 %load-immediate MOV ; -HOOK: rel-literal-x86 cpu ( literal -- ) - -M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ; +M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ; HOOK: ds-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg ) @@ -91,6 +94,88 @@ M: x86 %shl-imm nip SHL ; M: x86 %shr-imm nip SHR ; M: x86 %sar-imm nip SAR ; M: x86 %not drop NOT ; +M: x86 %log2 BSR ; + +: ?MOV ( dst src -- ) + 2dup = [ 2drop ] [ MOV ] if ; inline + +:: move>args ( src1 src2 -- ) + { + { [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] } + { [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] } + { [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] } + { [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] } + [ + param-reg-1 src1 MOV + param-reg-2 src2 MOV + ] + } cond ; + +HOOK: %alien-invoke-tail cpu ( func dll -- ) + +:: overflow-template ( src1 src2 insn inverse func -- ) +