steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-08-26 09:15:33 -05:00
parent 0ce57d0566 1420b6f4ee
commit bbcf08cdc3
31 changed files with 419 additions and 203 deletions
basis
alien
compiler
cpu
io/directories/unix
math/libm
specialized-arrays
direct/functor
functor
specialized-vectors/functor
core/alien/strings
extra
benchmark/raytracer
classes/struct

7
basis/alien/arrays/arrays-docs.factor
View File

@ -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 <c-type-array> }
{ $subsection <c-type-direct-array> } ;

6
basis/alien/arrays/arrays.factor
View File

@ -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*
[ <c-type-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;

17
basis/alien/c-types/c-types-docs.factor
View File

@ -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: <c-type>
{ $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 <c-type-array> } " or " { $link <c-type-direct-array> } " 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: <c-type-array>
{ $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: <c-type-direct-array>
{ $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

99
basis/alien/c-types/c-types.factor
View File

@ -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: <int>
@ -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: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
c-type-array-constructor execute( len -- array ) ; inline
M: string <c-type-array>
c-type <c-type-array> ; inline
M: array <c-type-array>
first c-type <c-type-array> ; inline
GENERIC: <c-type-direct-array> ( alien len c-type -- array )
M: object <c-type-direct-array>
c-type-direct-array-constructor execute( alien len -- array ) ; inline
M: string <c-type-direct-array>
c-type <c-type-direct-array> ; inline
M: array <c-type-direct-array>
first c-type <c-type-direct-array> ; 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 ]
[ "<direct-" "-array>" 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
<long-long-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
<long-long-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-type>
@ -434,6 +525,7 @@ CONSTANT: primitive-types
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" set-array-class
"bool" define-primitive-type
<c-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
<c-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

1
basis/alien/complex/functor/functor.factor
View File

@ -31,6 +31,7 @@ T c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
T set-array-class
drop
;FUNCTOR

21
basis/alien/structs/structs.factor
View File

@ -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 <c-type-array> ( len c-type -- array )
dup c-type-array-constructor
[ execute( len -- array ) ]
[ <struct-array> ] ?if ; inline
M: struct-type <c-type-direct-array> ( alien len c-type -- array )
dup c-type-direct-array-constructor
[ execute( alien len -- array ) ]
[ <direct-struct-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>>

30
basis/compiler/cfg/debugger/debugger.factor
View File

@ -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 ;
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 ;

1
basis/compiler/cfg/hats/hats.factor
View File

@ -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

3
basis/compiler/cfg/instructions/instructions.factor
View File

@ -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

3
basis/compiler/cfg/intrinsics/float/float.factor
View File

@ -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 ;

5
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -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 ] }

51
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -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

2
basis/compiler/codegen/codegen.factor
View File

@ -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 ;

18
basis/compiler/tests/low-level-ir.factor
View File

@ -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
*/
*/

16
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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

1
basis/cpu/architecture/architecture.factor
View File

@ -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 -- )

223
basis/cpu/ppc/assembler/assembler-tests.factor
View File

@ -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

16
basis/cpu/ppc/assembler/assembler.factor
View File

@ -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 ;

2
basis/cpu/ppc/ppc.factor
View File

@ -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) ;

7
basis/cpu/x86/32/32.factor
View File

@ -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

12
basis/cpu/x86/64/64.factor
View File

@ -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

1
basis/cpu/x86/x86.factor
View File

@ -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 ;

2
basis/io/directories/unix/unix.factor
View File

@ -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 ;

17
basis/math/libm/libm.factor
View File

@ -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

9
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -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
<A'> 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 <A'> ;
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
\ <A> >>direct-array-constructor
drop
;FUNCTOR

10
basis/specialized-arrays/functor/functor.factor
View File

@ -16,6 +16,7 @@ M: bad-byte-array-length summary
FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array
S DEFINES-CLASS ${T}-sequence
<A> 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
\ <A> >>array-constructor
\ S >>sequence-mixin-class
drop
;FUNCTOR

2
basis/specialized-vectors/functor/functor.factor
View File

@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector
A IS ${T}-array
S IS ${T}-sequence
<A> 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

3
core/alien/strings/strings.factor
View File

@ -12,6 +12,9 @@ M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
M: object alien>string
[ underlying>> ] dip alien>string ;
M: f alien>string
drop ;

2
extra/benchmark/raytracer/raytracer.factor
View File

@ -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 )

23
extra/classes/struct/struct-tests.factor
View File

@ -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 <struct> byte-length ] unit-test
[ 16 ] [ struct-test-bar heap-size ] unit-test
[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
[ 123 ] [ struct-test-bar <struct> 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 <struct-boa> 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 <struct> y>> 4 swap nth ] unit-test
[ t ] [
struct-test-array-slots <struct>
[ y>> [ 8 3 ] dip set-nth ]
[ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
] unit-test

12
extra/classes/struct/struct.factor
View File

@ -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 ;