diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index c5efe1e030..e8ebe1824d 100644 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ; 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" } "." ; +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." +$nl +"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:" +{ $subsection require-c-type-arrays } +{ $subsection } +{ $subsection } ; diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index d793814c28..fbf59e6f11 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -29,7 +29,11 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: array c-type-boxer-quot drop [ ] ; +M: array c-type-boxer-quot + unclip + [ product ] + [ [ require-c-type-arrays ] keep ] bi* + [ ] 2curry ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index c9c1ecd0e5..f5f9e004c4 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors ; +io.encodings.string debugger destructors vocabs.loader ; HELP: { $values { "type" hashtable } } @@ -128,6 +128,21 @@ HELP: malloc-string } } ; +HELP: require-c-type-arrays +{ $values { "c-type" "a C type" } } +{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " vocabularies." } +{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ; + +HELP: +{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } } +{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ; + +HELP: +{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } } +{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." } +{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; + ARTICLE: "c-strings" "C strings" "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." $nl diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 2eba6a2b9e..9f7ac75558 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser cpu.architecture alien alien.accessors alien.strings quotations layouts system compiler.units io io.files io.encodings.binary io.streams.memory accessors combinators effects continuations fry -classes ; +classes vocabs vocabs.loader ; IN: alien.c-types DEFER: @@ -21,7 +21,12 @@ TUPLE: abstract-c-type { getter callable } { setter callable } size -align ; +align +array-class +array-constructor +direct-array-class +direct-array-constructor +sequence-mixin-class ; TUPLE: c-type < abstract-c-type boxer @@ -71,6 +76,51 @@ M: string c-type ( name -- type ) ] ?if ] if ; +: ?require-word ( word/pair -- ) + dup word? [ drop ] [ first require ] ?if ; + +GENERIC: require-c-type-arrays ( c-type -- ) + +M: object require-c-type-arrays + drop ; + +M: c-type require-c-type-arrays + [ array-class>> ?require-word ] + [ sequence-mixin-class>> ?require-word ] + [ direct-array-class>> ?require-word ] tri ; + +M: string require-c-type-arrays + c-type require-c-type-arrays ; + +M: array require-c-type-arrays + first c-type require-c-type-arrays ; + +ERROR: specialized-array-vocab-not-loaded vocab word ; + +: c-type-array-constructor ( c-type -- word ) + array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable + +: c-type-direct-array-constructor ( c-type -- word ) + direct-array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable + +GENERIC: ( len c-type -- array ) +M: object + c-type-array-constructor execute( len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline + +GENERIC: ( alien len c-type -- array ) +M: object + c-type-direct-array-constructor execute( alien len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline + GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; @@ -293,6 +343,36 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: ?lookup ( vocab word -- word/pair ) + over vocab [ swap lookup ] [ 2array ] if ; + +: set-array-class* ( c-type vocab-stem type-stem -- c-type ) + { + [ + [ "specialized-arrays." prepend ] + [ "-array" append ] bi* ?lookup >>array-class + ] + [ + [ "specialized-arrays." prepend ] + [ "<" "-array>" surround ] bi* ?lookup >>array-constructor + ] + [ + [ "specialized-arrays." prepend ] + [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class + ] + [ + [ "specialized-arrays.direct." prepend ] + [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class + ] + [ + [ "specialized-arrays.direct." prepend ] + [ "" surround ] bi* ?lookup >>direct-array-constructor + ] + } 2cleave ; + +: set-array-class ( c-type stem -- c-type ) + dup set-array-class* ; + CONSTANT: primitive-types { "char" "uchar" @@ -315,6 +395,7 @@ CONSTANT: primitive-types [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer + "alien" "void*" set-array-class* "void*" define-primitive-type @@ -326,6 +407,7 @@ CONSTANT: primitive-types 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer + "longlong" set-array-class "longlong" define-primitive-type @@ -337,6 +419,7 @@ CONSTANT: primitive-types 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer + "ulonglong" set-array-class "ulonglong" define-primitive-type @@ -348,6 +431,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer + "long" set-array-class "long" define-primitive-type @@ -359,6 +443,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer + "ulong" set-array-class "ulong" define-primitive-type @@ -370,6 +455,7 @@ CONSTANT: primitive-types 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer + "int" set-array-class "int" define-primitive-type @@ -381,6 +467,7 @@ CONSTANT: primitive-types 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer + "uint" set-array-class "uint" define-primitive-type @@ -392,6 +479,7 @@ CONSTANT: primitive-types 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer + "short" set-array-class "short" define-primitive-type @@ -403,6 +491,7 @@ CONSTANT: primitive-types 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer + "ushort" set-array-class "ushort" define-primitive-type @@ -414,6 +503,7 @@ CONSTANT: primitive-types 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer + "char" set-array-class "char" define-primitive-type @@ -425,6 +515,7 @@ CONSTANT: primitive-types 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer + "uchar" set-array-class "uchar" define-primitive-type @@ -434,6 +525,7 @@ CONSTANT: primitive-types 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer + "bool" set-array-class "bool" define-primitive-type @@ -447,6 +539,7 @@ CONSTANT: primitive-types "to_float" >>unboxer single-float-rep >>rep [ >float ] >>unboxer-quot + "float" set-array-class "float" define-primitive-type @@ -460,9 +553,11 @@ CONSTANT: primitive-types "to_double" >>unboxer double-float-rep >>rep [ >float ] >>unboxer-quot + "double" set-array-class "double" define-primitive-type "long" "ptrdiff_t" typedef "long" "intptr_t" typedef "ulong" "size_t" typedef ] with-compilation-unit + diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 98d412639f..7727546c00 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -31,6 +31,7 @@ T c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot number >>boxed-class +T set-array-class drop ;FUNCTOR diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 5c1fb4063b..d8b2edf394 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order -quotations byte-arrays ; +quotations byte-arrays struct-arrays ; IN: alien.structs TUPLE: struct-type < abstract-c-type fields return-in-registers? ; @@ -12,6 +12,16 @@ M: struct-type c-type ; M: struct-type c-type-stack-align? drop f ; +M: struct-type ( len c-type -- array ) + dup c-type-array-constructor + [ execute( len -- array ) ] + [ ] ?if ; inline + +M: struct-type ( alien len c-type -- array ) + dup c-type-direct-array-constructor + [ execute( alien len -- array ) ] + [ ] ?if ; inline + : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline @@ -35,9 +45,8 @@ M: struct-type stack-size : c-struct? ( type -- ? ) (c-type) struct-type? ; -: (define-struct) ( name size align fields -- ) - [ [ align ] keep ] dip - struct-type new +: (define-struct) ( name size align fields class -- ) + [ [ align ] keep ] 2dip new byte-array >>class byte-array >>boxed-class swap >>fields @@ -55,13 +64,13 @@ M: struct-type stack-size [ 2drop ] [ make-fields ] 3bi [ struct-offsets ] keep [ [ type>> ] map compute-struct-align ] keep - [ (define-struct) ] keep + [ struct-type (define-struct) ] keep [ define-field ] each ; : define-union ( name members -- ) [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep - compute-struct-align f (define-struct) ; + compute-struct-align f struct-type (define-struct) ; : offset-of ( field struct -- offset ) c-types get at fields>> diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 33f87ff1d4..d51aa477c9 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words sequences quotations namespaces io vectors -classes.tuple accessors prettyprint prettyprint.config assocs -prettyprint.backend prettyprint.custom prettyprint.sections -parser compiler.tree.builder compiler.tree.optimizer -cpu.architecture compiler.cfg.builder compiler.cfg.linearization -compiler.cfg.registers compiler.cfg.stack-frame -compiler.cfg.linear-scan compiler.cfg.two-operand -compiler.cfg.optimizer compiler.cfg.instructions -compiler.cfg.utilities compiler.cfg.def-use -compiler.cfg.rpo compiler.cfg.mr compiler.cfg ; +arrays hashtables classes.tuple accessors prettyprint +prettyprint.config assocs prettyprint.backend prettyprint.custom +prettyprint.sections parser compiler.tree.builder +compiler.tree.optimizer cpu.architecture compiler.cfg.builder +compiler.cfg.linearization compiler.cfg.registers +compiler.cfg.stack-frame compiler.cfg.linear-scan +compiler.cfg.two-operand compiler.cfg.optimizer +compiler.cfg.instructions compiler.cfg.utilities +compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr +compiler.cfg.representations.preferred compiler.cfg ; IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) @@ -73,8 +74,9 @@ M: rs-loc pprint* \ R pprint-loc ; : fake-representations ( cfg -- ) post-order [ - instructions>> - [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] - map concat - ] map concat - [ int-rep ] H{ } map>assoc representations set ; \ No newline at end of file + instructions>> [ + [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ] + [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ] + bi [ suffix ] when* + ] map concat + ] map concat >hashtable representations set ; \ No newline at end of file diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 04fddbb203..d90745a25e 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -43,6 +43,7 @@ IN: compiler.cfg.hats : ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline : ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline : ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline +: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline : ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline : ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline : ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 4cf4340bd7..87c6909a9f 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -106,6 +106,7 @@ INSN: ##add-float < ##commutative ; INSN: ##sub-float < ##binary ; INSN: ##mul-float < ##commutative ; INSN: ##div-float < ##binary ; +INSN: ##sqrt < ##unary ; ! Float/integer conversion INSN: ##float>integer < ##unary ; @@ -256,6 +257,7 @@ UNION: output-float-insn ##sub-float ##mul-float ##div-float + ##sqrt ##integer>float ##unbox-float ##alien-float @@ -267,6 +269,7 @@ UNION: input-float-insn ##sub-float ##mul-float ##div-float + ##sqrt ##float>integer ##box-float ##set-alien-float diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 152be80286..9d0af29a15 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -15,3 +15,6 @@ IN: compiler.cfg.intrinsics.float : emit-fixnum>float ( -- ) ds-pop ^^untag-fixnum ^^integer>float ds-push ; + +: emit-fsqrt ( -- ) + ds-pop ^^sqrt ds-push ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 363197c3c0..27d9970a91 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -19,6 +19,7 @@ QUALIFIED: strings.private QUALIFIED: classes.tuple.private QUALIFIED: math.private QUALIFIED: math.integers.private +QUALIFIED: math.libm QUALIFIED: alien.accessors IN: compiler.cfg.intrinsics @@ -92,6 +93,9 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-double } [ t "intrinsic" set-word-prop ] each ; +: enable-fsqrt ( -- ) + \ math.libm:fsqrt t "intrinsic" set-word-prop ; + : enable-fixnum-log2 ( -- ) \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; @@ -130,6 +134,7 @@ IN: compiler.cfg.intrinsics { \ math.private:float= [ drop cc= emit-float-comparison ] } { \ math.private:float>fixnum [ drop emit-float>fixnum ] } { \ math.private:fixnum>float [ drop emit-fixnum>float ] } + { \ math.libm:fsqrt [ drop emit-fsqrt ] } { \ slots.private:slot [ emit-slot ] } { \ slots.private:set-slot [ emit-set-slot ] } { \ strings.private:string-nth [ drop emit-string-nth ] } diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index b7a97e75c6..062c62adab 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -656,14 +656,17 @@ V{ T{ ##copy { dst 689481 } { src 689475 } + { rep int-rep } } T{ ##copy { dst 689482 } { src 689474 } + { rep int-rep } } T{ ##copy { dst 689483 } { src 689473 } + { rep int-rep } } T{ ##branch } } 2 test-bb @@ -672,14 +675,17 @@ V{ T{ ##copy { dst 689481 } { src 689473 } + { rep int-rep } } T{ ##copy { dst 689482 } { src 689475 } + { rep int-rep } } T{ ##copy { dst 689483 } { src 689474 } + { rep int-rep } } T{ ##branch } } 3 test-bb @@ -742,10 +748,12 @@ V{ T{ ##copy { dst 689608 } { src 689600 } + { rep int-rep } } T{ ##copy { dst 689610 } { src 689601 } + { rep int-rep } } T{ ##branch } } 2 test-bb @@ -758,14 +766,17 @@ V{ T{ ##copy { dst 689607 } { src 689600 } + { rep int-rep } } T{ ##copy { dst 689608 } { src 689601 } + { rep int-rep } } T{ ##copy { dst 689610 } { src 689609 } + { rep int-rep } } T{ ##branch } } 3 test-bb @@ -816,6 +827,7 @@ V{ T{ ##copy { dst 2 } { src 1 } + { rep int-rep } } T{ ##branch } } 2 test-bb @@ -828,6 +840,7 @@ V{ T{ ##copy { dst 2 } { src 3 } + { rep int-rep } } T{ ##branch } } 3 test-bb @@ -1121,7 +1134,7 @@ V{ { slot 1 } { tag 2 } } - T{ ##copy { dst 79 } { src 69 } } + T{ ##copy { dst 79 } { src 69 } { rep int-rep } } T{ ##slot-imm { dst 85 } { obj 62 } @@ -1169,22 +1182,22 @@ V{ T{ ##peek { dst 114 } { loc D 1 } } T{ ##peek { dst 116 } { loc D 4 } } T{ ##peek { dst 119 } { loc R 0 } } - T{ ##copy { dst 109 } { src 108 } } - T{ ##copy { dst 111 } { src 110 } } - T{ ##copy { dst 113 } { src 112 } } - T{ ##copy { dst 115 } { src 114 } } - T{ ##copy { dst 117 } { src 116 } } - T{ ##copy { dst 120 } { src 119 } } + T{ ##copy { dst 109 } { src 108 } { rep int-rep } } + T{ ##copy { dst 111 } { src 110 } { rep int-rep } } + T{ ##copy { dst 113 } { src 112 } { rep int-rep } } + T{ ##copy { dst 115 } { src 114 } { rep int-rep } } + T{ ##copy { dst 117 } { src 116 } { rep int-rep } } + T{ ##copy { dst 120 } { src 119 } { rep int-rep } } T{ ##branch } } 3 test-bb V{ - T{ ##copy { dst 109 } { src 62 } } - T{ ##copy { dst 111 } { src 61 } } - T{ ##copy { dst 113 } { src 62 } } - T{ ##copy { dst 115 } { src 79 } } - T{ ##copy { dst 117 } { src 64 } } - T{ ##copy { dst 120 } { src 69 } } + T{ ##copy { dst 109 } { src 62 } { rep int-rep } } + T{ ##copy { dst 111 } { src 61 } { rep int-rep } } + T{ ##copy { dst 113 } { src 62 } { rep int-rep } } + T{ ##copy { dst 115 } { src 79 } { rep int-rep } } + T{ ##copy { dst 117 } { src 64 } { rep int-rep } } + T{ ##copy { dst 120 } { src 69 } { rep int-rep } } T{ ##branch } } 4 test-bb @@ -1306,12 +1319,12 @@ V{ T{ ##peek { dst 162 } { loc D 1 } } T{ ##peek { dst 164 } { loc D 4 } } T{ ##peek { dst 167 } { loc R 0 } } - T{ ##copy { dst 157 } { src 156 } } - T{ ##copy { dst 159 } { src 158 } } - T{ ##copy { dst 161 } { src 160 } } - T{ ##copy { dst 163 } { src 162 } } - T{ ##copy { dst 165 } { src 164 } } - T{ ##copy { dst 168 } { src 167 } } + T{ ##copy { dst 157 } { src 156 } { rep int-rep } } + T{ ##copy { dst 159 } { src 158 } { rep int-rep } } + T{ ##copy { dst 161 } { src 160 } { rep int-rep } } + T{ ##copy { dst 163 } { src 162 } { rep int-rep } } + T{ ##copy { dst 165 } { src 164 } { rep int-rep } } + T{ ##copy { dst 168 } { src 167 } { rep int-rep } } T{ ##branch } } 4 test-bb diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d1b5558beb..6395d8644f 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -170,6 +170,8 @@ M: ##sub-float generate-insn dst/src1/src2 %sub-float ; M: ##mul-float generate-insn dst/src1/src2 %mul-float ; M: ##div-float generate-insn dst/src1/src2 %div-float ; +M: ##sqrt generate-insn dst/src %sqrt ; + M: ##integer>float generate-insn dst/src %integer>float ; M: ##float>integer generate-insn dst/src %float>integer ; diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index ececac3037..d67aaef43b 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -3,7 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr compiler.cfg.registers compiler.codegen compiler.units cpu.architecture hashtables kernel namespaces sequences tools.test vectors words layouts literals math arrays -alien.syntax ; +alien.syntax math.private ; IN: compiler.tests.low-level-ir : compile-cfg ( cfg -- word ) @@ -46,6 +46,20 @@ IN: compiler.tests.low-level-ir } compile-test-bb ] unit-test +! ##copy on floats. We can only run this test if float intrinsics +! are enabled. +\ float+ "intrinsic" word-prop [ + [ 1.5 ] [ + V{ + T{ ##load-reference f 4 1.5 } + T{ ##unbox-float f 1 4 } + T{ ##copy f 2 1 double-float-rep } + T{ ##box-float f 3 2 } + T{ ##copy f 0 3 int-rep } + } compile-test-bb + ] unit-test +] when + ! make sure slot access works when the destination is ! one of the sources [ t ] [ @@ -138,4 +152,4 @@ USE: multiline } compile-test-bb ] unit-test -*/ \ No newline at end of file +*/ diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 3a20424e18..2387db3c15 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -2,11 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private math.integers.private math.partial-dispatch math.intervals -math.parser math.order math.functions 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 strings.private -vectors hashtables generic quotations +math.parser math.order math.functions math.libm 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 strings.private vectors hashtables +generic quotations stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -297,3 +298,8 @@ generic-comparison-ops [ bi ] [ 2drop object-info ] if ] "outputs" set-word-prop + +{ facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp +flog fpow fsqrt facosh fasinh fatanh } [ + { float } "default-output-classes" set-word-prop +] each diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 7bb9caec9b..71200e1ede 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -110,6 +110,7 @@ HOOK: %add-float cpu ( dst src1 src2 -- ) HOOK: %sub-float cpu ( dst src1 src2 -- ) HOOK: %mul-float cpu ( dst src1 src2 -- ) HOOK: %div-float cpu ( dst src1 src2 -- ) +HOOK: %sqrt cpu ( dst src -- ) HOOK: %integer>float cpu ( dst src -- ) HOOK: %float>integer cpu ( dst src -- ) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 6ee1c84558..8e412c4c83 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -1,117 +1,120 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces -make vocabs sequences ; +make vocabs sequences byte-arrays.hex ; FROM: cpu.ppc.assembler => B ; IN: cpu.ppc.assembler.tests : test-assembler ( expected quot -- ) [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; -B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler -B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler -B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler -B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler -B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler -B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler -B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler -B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler -B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler -B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler -B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler -B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler -B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler -B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler -B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler -B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler -B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler -B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler -B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler -B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler -B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler -B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler -B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler -B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler -B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler -B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler -B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler -B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler -B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler -B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler -B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler -B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler -B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler -B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler -B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler -B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler -B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler -B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler -B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler -B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler -B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler -B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler -B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler -B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler -B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler -B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler -B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler -B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler -B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler -B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler -B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler -B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler -B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler -B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler -B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler -B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler -B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler -B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler -B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler -B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler -B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler -B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler -B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler -B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler -B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler -B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler -B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler -B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler -B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler -B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler +HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler +HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler +HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler +HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler +HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler +HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler +HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler +HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler +HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler +HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler +HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler +HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler +HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler +HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler +HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler +HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler +HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler +HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler +HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler +HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler +HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler +HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler +HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler +HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler +HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler +HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler +HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler +HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler +HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler +HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler +HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler +HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler +HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler +HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler +HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler +HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler +HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler +HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler +HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler +HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler +HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler +HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler +HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler +HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler +HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler +HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler +HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler +HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler +HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler +HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler +HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler +HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler +HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler +HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler +HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler +HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler +HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler +HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler +HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler +HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler +HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler +HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler +HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler +HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler +HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler +HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler +HEX{ 48 00 00 01 } [ 1 B ] test-assembler +HEX{ 48 00 00 01 } [ 1 BL ] test-assembler +HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler +HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler +HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler +HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler +HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler +HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler +HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler +HEX{ 41 83 00 04 } [ 1 BO ] test-assembler +HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler +HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler +HEX{ 4e 80 00 20 } [ BLR ] test-assembler +HEX{ 4e 80 00 21 } [ BLRL ] test-assembler +HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler +HEX{ 4e 80 04 20 } [ BCTR ] test-assembler +HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler +HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler +HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler +HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler +HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler +HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler +HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler +HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler +HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler +HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler +HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler +HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler +HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler +HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler +HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler +HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler +HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler +HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler +HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler +HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler +HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler +HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler +HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler +HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler +HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler +HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler +HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler +HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler +HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler +HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index 2daf3678ce..dd633f4e9a 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces words io.binary math math.order +USING: kernel namespaces words math math.order locals cpu.ppc.assembler.backend ; IN: cpu.ppc.assembler @@ -97,8 +97,8 @@ X: XOR 0 316 31 X: XOR. 1 316 31 X1: EXTSB 0 954 31 X1: EXTSB. 1 954 31 -: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ; -: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ; +: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ; +: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ; : FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ; : FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ; @@ -189,9 +189,9 @@ MTSPR: LR 8 MTSPR: CTR 9 ! Pseudo-instructions -: LI ( value dst -- ) 0 rot ADDI ; inline +: LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline : SUBI ( dst src1 src2 -- ) neg ADDI ; inline -: LIS ( value dst -- ) 0 rot ADDIS ; inline +: LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline : SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline : SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline : NOT ( dst src -- ) dup NOR ; inline @@ -204,6 +204,8 @@ MTSPR: CTR 9 : (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline : SRWI ( d a b -- ) (SRWI) RLWINM ; : SRWI. ( d a b -- ) (SRWI) RLWINM. ; -: LOAD32 ( n r -- ) [ w>h/h ] dip tuck LIS dup rot ORI ; +:: LOAD32 ( n r -- ) + n -16 shift HEX: ffff bitand r LIS + r r n HEX: ffff bitand ORI ; : immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ; : LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index d6674e7097..aec7e85b56 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -62,7 +62,7 @@ M: rs-loc loc-reg drop rs-reg ; M: ppc %peek loc>operand LWZ ; M: ppc %replace loc>operand STW ; -: (%inc) ( n reg -- ) dup rot cells ADDI ; inline +:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline M: ppc %inc-d ( n -- ) ds-reg (%inc) ; M: ppc %inc-r ( n -- ) rs-reg (%inc) ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index bd03b47302..8808c47995 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -208,13 +208,13 @@ M: x86 %unbox-small-struct ( size -- ) { 2 [ %unbox-struct-2 ] } } case ; -M: x86.32 %unbox-large-struct ( n c-type -- ) +M:: x86.32 %unbox-large-struct ( n c-type -- ) ! Alien must be in EAX. ! Compute destination address - ECX rot stack@ LEA + ECX n stack@ LEA 12 [ ! Push struct size - heap-size PUSH + c-type heap-size PUSH ! Push destination address ECX PUSH ! Push source address @@ -304,6 +304,7 @@ USING: cpu.x86.features cpu.x86.features.private ; sse2? [ " - yes" print enable-float-intrinsics + enable-fsqrt [ sse2? [ "This image was built to use SSE2, which your CPU does not support." print diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 7c832fe66c..153e2c511b 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -102,13 +102,12 @@ M: x86.64 %unbox-small-struct ( c-type -- ) flatten-value-type [ %unbox-struct-field ] each-index ] with-return-regs ; -M: x86.64 %unbox-large-struct ( n c-type -- ) +M:: x86.64 %unbox-large-struct ( n c-type -- ) ! Source is in param-reg-1 - heap-size - ! Load destination address - param-reg-2 rot param@ LEA - ! Load structure size - param-reg-3 swap MOV + ! Load destination address into param-reg-2 + param-reg-2 n param@ LEA + ! Load structure size into param-reg-3 + param-reg-3 c-type heap-size MOV ! Copy the struct to the C stack "to_value_struct" f %alien-invoke ; @@ -204,6 +203,7 @@ enable-alien-4-intrinsics ! SSE2 is always available on x86-64. enable-float-intrinsics +enable-fsqrt USE: vocabs.loader diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index a6c958083c..f61dd82276 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -203,6 +203,7 @@ M: x86 %add-float nip ADDSD ; M: x86 %sub-float nip SUBSD ; M: x86 %mul-float nip MULSD ; M: x86 %div-float nip DIVSD ; +M: x86 %sqrt SQRTSD ; M: x86 %integer>float CVTSI2SD ; M: x86 %float>integer CVTTSD2SI ; diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index b8b781ec12..a107a46275 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -57,7 +57,7 @@ M: unix find-next-file ( DIR* -- byte-array ) M: unix >directory-entry ( byte-array -- directory-entry ) { - [ dirent-d_name utf8 alien>string ] + [ dirent-d_name underlying>> utf8 alien>string ] [ dirent-d_type dirent-type>file-type ] } cleave directory-entry boa ; diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor index 96f5f134cc..e2bd2ef6eb 100644 --- a/basis/math/libm/libm.factor +++ b/basis/math/libm/libm.factor @@ -5,69 +5,52 @@ IN: math.libm : facos ( x -- y ) "double" "libm" "acos" { "double" } alien-invoke ; - inline : fasin ( x -- y ) "double" "libm" "asin" { "double" } alien-invoke ; - inline : fatan ( x -- y ) "double" "libm" "atan" { "double" } alien-invoke ; - inline : fatan2 ( x y -- z ) "double" "libm" "atan2" { "double" "double" } alien-invoke ; - inline : fcos ( x -- y ) "double" "libm" "cos" { "double" } alien-invoke ; - inline : fsin ( x -- y ) "double" "libm" "sin" { "double" } alien-invoke ; - inline : ftan ( x -- y ) "double" "libm" "tan" { "double" } alien-invoke ; - inline : fcosh ( x -- y ) "double" "libm" "cosh" { "double" } alien-invoke ; - inline : fsinh ( x -- y ) "double" "libm" "sinh" { "double" } alien-invoke ; - inline : ftanh ( x -- y ) "double" "libm" "tanh" { "double" } alien-invoke ; - inline : fexp ( x -- y ) "double" "libm" "exp" { "double" } alien-invoke ; - inline : flog ( x -- y ) "double" "libm" "log" { "double" } alien-invoke ; - inline : fpow ( x y -- z ) "double" "libm" "pow" { "double" "double" } alien-invoke ; - inline : fsqrt ( x -- y ) "double" "libm" "sqrt" { "double" } alien-invoke ; - inline ! Windows doesn't have these... : facosh ( x -- y ) "double" "libm" "acosh" { "double" } alien-invoke ; - inline : fasinh ( x -- y ) "double" "libm" "asinh" { "double" } alien-invoke ; - inline : fatanh ( x -- y ) "double" "libm" "atanh" { "double" } alien-invoke ; - inline diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index b49dfa35e4..37978b6dfa 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -8,6 +8,7 @@ IN: specialized-arrays.direct.functor FUNCTOR: define-direct-array ( T -- ) A' IS ${T}-array +S IS ${T}-sequence >A' IS >${T}-array IS <${A'}> A'{ IS ${A'}{ @@ -31,6 +32,8 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; M: A like drop dup A instance? [ >A' ] unless ; M: A new-sequence drop ; +M: A byte-length length>> T heap-size * ; + M: A pprint-delims drop \ A'{ \ } ; M: A >pprint-sequence ; @@ -38,5 +41,11 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; INSTANCE: A sequence +INSTANCE: A S + +T c-type + \ A >>direct-array-class + \ >>direct-array-constructor + drop ;FUNCTOR diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 06b9aef17d..3341a909d2 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -16,6 +16,7 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) A DEFINES-CLASS ${T}-array +S DEFINES-CLASS ${T}-sequence DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} @@ -27,6 +28,8 @@ SET-NTH [ T dup c-setter array-accessor ] WHERE +MIXIN: S + TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; @@ -73,7 +76,14 @@ M: A pprint* pprint-object ; SYNTAX: A{ \ } [ >A ] parse-literal ; INSTANCE: A sequence +INSTANCE: A S A T c-type-boxed-class specialize-vector-words +T c-type + \ A >>array-class + \ >>array-constructor + \ S >>sequence-mixin-class + drop + ;FUNCTOR diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 08c44cd197..27bba3f9a6 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- ) V DEFINES-CLASS ${T}-vector A IS ${T}-array +S IS ${T}-sequence IS <${A}> >V DEFERS >${V} @@ -32,5 +33,6 @@ M: V pprint* pprint-object ; SYNTAX: V{ \ } [ >V ] parse-literal ; INSTANCE: V growable +INSTANCE: V S ;FUNCTOR diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index c74c325726..ff20b8b033 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -12,6 +12,9 @@ M: c-ptr alien>string [ ] [ ] bi* "\0" swap stream-read-until drop ; +M: object alien>string + [ underlying>> ] dip alien>string ; + M: f alien>string drop ; diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 25915404be..de9b80b4ca 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -155,7 +155,7 @@ DEFER: create ( level c r -- scene ) ] with map ; : ray-pixel ( scene point -- n ) - ss-grid ray-grid 0.0 -rot + ss-grid ray-grid [ 0.0 ] 2dip [ [ swap cast-ray + ] with each ] with each ; : pixel-grid ( -- grid ) diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 51df207003..6c7a4cf35d 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,9 +1,10 @@ ! (c)Joe Groff bsd license USING: accessors alien.c-types alien.libraries -alien.structs.fields alien.syntax classes.struct combinators -destructors io.pathnames io.streams.string kernel libc literals math -multiline namespaces prettyprint prettyprint.config see system -tools.test ; +alien.structs.fields alien.syntax ascii classes.struct combinators +destructors io.encodings.utf8 io.pathnames io.streams.string +kernel libc literals math multiline namespaces prettyprint +prettyprint.config see sequences specialized-arrays.ushort +system tools.test ; IN: classes.struct.tests << @@ -30,6 +31,7 @@ STRUCT: struct-test-bar { foo struct-test-foo } ; [ 12 ] [ struct-test-foo heap-size ] unit-test +[ 12 ] [ struct-test-foo byte-length ] unit-test [ 16 ] [ struct-test-bar heap-size ] unit-test [ 123 ] [ struct-test-foo y>> ] unit-test [ 123 ] [ struct-test-bar foo>> y>> ] unit-test @@ -144,3 +146,16 @@ LIBRARY: f-cdecl FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ; [ 14 ] [ 1 2 3 struct-test-ffi-foo 4 ffi_test_11 ] unit-test + +STRUCT: struct-test-array-slots + { x int } + { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } } + { z int } ; + +[ 11 ] [ struct-test-array-slots y>> 4 swap nth ] unit-test + +[ t ] [ + struct-test-array-slots + [ y>> [ 8 3 ] dip set-nth ] + [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi +] unit-test diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 51df296f1a..e9de2f7e36 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -94,6 +94,10 @@ M: struct-class writer-quot [ \ struct-slot-values create-method-in ] [ struct-slot-values-quot ] bi define ; +: (define-byte-length-method) ( class -- ) + [ \ byte-length create-method-in ] + [ heap-size \ drop swap [ ] 2sequence ] bi define ; + ! Struct as c-type : slot>field ( slot -- field ) @@ -113,7 +117,7 @@ M: struct-class writer-quot [ "struct-align" word-prop ] [ struct-slots [ slot>field ] map ] } cleave - (define-struct) + struct-type (define-struct) ] [ { [ name>> c-type ] @@ -172,6 +176,10 @@ M: struct-class heap-size over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if ] each ; +: (struct-methods) ( class -- ) + [ (define-struct-slot-values-method) ] + [ (define-byte-length-method) ] bi ; + : (struct-word-props) ( class slots size align -- ) [ [ "struct-slots" set-word-prop ] @@ -181,7 +189,7 @@ M: struct-class heap-size [ "struct-align" set-word-prop ] tri-curry* [ tri ] 3curry [ dup struct-prototype "prototype" set-word-prop ] - [ (define-struct-slot-values-method) ] tri ; + [ (struct-methods) ] tri ; : check-struct-slots ( slots -- ) [ c-type>> c-type drop ] each ;