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

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

db4
Joe Groff 2009-09-08 15:37:32 -05:00
parent 0ec342a1c5 e2fa28a727
commit 2ad9459b85
178 changed files with 3502 additions and 1654 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/arrays/arrays-docs.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ ARTICLE: "c-arrays" "C arrays"
$nl
"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-arrays }
"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"
{ $subsection require-c-array }
{ $subsection <c-array> }
{ $subsection <c-direct-array> } ;

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

@ -35,7 +35,7 @@ M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-arrays ] keep ] bi*
[ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;

12
basis/alien/c-types/c-types-docs.factor Normal file → Executable file
View File

@ -51,7 +51,7 @@ HELP: c-setter
HELP: <c-array>
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $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-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
@ -73,7 +73,7 @@ HELP: byte-array>memory
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
{ $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-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
@ -130,15 +130,15 @@ HELP: malloc-string
}
} ;
HELP: require-c-arrays
HELP: require-c-array
{ $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-array> } " or " { $link <c-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." } ;
{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence types loaded." } ;
HELP: <c-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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
{ $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-array } " word. See the " { $vocab-link "specialized-arrays" } " 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."

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

@ -25,9 +25,7 @@ align
array-class
array-constructor
(array)-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;
direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
@ -89,21 +87,19 @@ M: string heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: require-c-arrays ( c-type -- )
GENERIC: require-c-array ( c-type -- )
M: object require-c-arrays
M: object require-c-array
drop ;
M: c-type require-c-arrays
[ array-class>> ?require-word ]
[ sequence-mixin-class>> ?require-word ]
[ direct-array-class>> ?require-word ] tri ;
M: c-type require-c-array
array-class>> ?require-word ;
M: string require-c-arrays
c-type require-c-arrays ;
M: string require-c-array
c-type require-c-array ;
M: array require-c-arrays
first c-type require-c-arrays ;
M: array require-c-array
first c-type require-c-array ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
@ -370,14 +366,6 @@ M: long-long-type box-return ( type -- )
]
[
[ "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 ;
@ -549,7 +537,7 @@ CONSTANT: primitive-types
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
single-float-rep >>rep
float-rep >>rep
[ >float ] >>unboxer-quot
"float" set-array-class
"float" define-primitive-type
@ -563,7 +551,7 @@ CONSTANT: primitive-types
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
double-float-rep >>rep
double-rep >>rep
[ >float ] >>unboxer-quot
"double" set-array-class
"double" define-primitive-type

8
basis/classes/struct/struct-tests.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.char
specialized-arrays.direct.int specialized-arrays.ushort
specialized-arrays.int specialized-arrays.ushort
struct-arrays system tools.test ;
IN: classes.struct.tests
@ -316,6 +316,11 @@ STRUCT: struct-test-optimization
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
{ x>> } inlined?
] unit-test
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
@ -340,3 +345,4 @@ STRUCT: struct-that's-a-word { x int } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test

23
basis/classes/struct/struct.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ combinators combinators.short-circuit combinators.smart
definitions functors.backend fry generalizations generic.parser
kernel kernel.private lexer libc locals macros make math math.order
parser quotations sequences slots slots.private struct-arrays vectors
words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ;
words compiler.tree.propagation.transforms specialized-arrays.uchar ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
@ -20,8 +20,7 @@ TUPLE: struct
TUPLE: struct-slot-spec < slot-spec
c-type ;
PREDICATE: struct-class < tuple-class
{ [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
: struct-slots ( struct-class -- slots )
"struct-slots" word-prop ;
@ -43,11 +42,9 @@ M: struct hashcode*
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: memory>struct ( ptr class -- struct )
[ 1array ] dip slots>tuple ;
\ memory>struct [
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
] 1 define-partial-eval
! This is sub-optimal if the class is not literal, but gets
! optimized down to efficient code if it is.
'[ _ boa ] call( ptr -- struct ) ; inline
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
@ -126,10 +123,6 @@ M: struct-class writer-quot
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
: (define-byte-length-method) ( class -- )
[ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi
define-inline-method ;
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
@ -203,6 +196,9 @@ M: struct-class c-type-unboxer-quot
M: struct-class heap-size
"struct-size" word-prop ;
M: struct byte-length
class "struct-size" word-prop ; foldable
! class definition
<PRIVATE
@ -218,9 +214,8 @@ M: struct-class heap-size
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
[ (define-byte-length-method) ]
[ (define-clone-method) ]
tri ;
bi ;
: (struct-word-props) ( class slots size align -- )
[

2
basis/cocoa/enumeration/enumeration.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
locals math sequences vectors fry libc destructors ;
IN: cocoa.enumeration
<< "id" require-c-arrays >>
<< "id" require-c-array >>
CONSTANT: NS-EACH-BUFFER-SIZE 16

2
basis/cocoa/messages/messages.factor Normal file → Executable file
View File

@ -5,7 +5,7 @@ classes.struct continuations combinators compiler compiler.alien
stack-checker kernel math namespaces make quotations sequences
strings words cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private lexer init core-foundation fry
generalizations specialized-arrays.direct.alien ;
generalizations specialized-arrays.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )

2
basis/colors/constants/constants-docs.factor
View File

@ -23,7 +23,7 @@ HELP: COLOR:
} ;
ARTICLE: "colors.constants" "Standard color database"
"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values."
"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name."
{ $subsection named-color }
{ $subsection named-colors }
{ $subsection POSTPONE: COLOR: } ;

14
basis/colors/constants/constants.factor
View File

@ -1,17 +1,15 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math math.parser memoize io.encodings.utf8
io.files lexer parser colors sequences splitting
combinators.smart ascii ;
io.files lexer parser colors sequences splitting ascii ;
IN: colors.constants
<PRIVATE
: parse-color ( line -- name color )
[
[ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
[ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap
] input<sequence ;
first4
[ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
[ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ;
: parse-rgb.txt ( lines -- assoc )
[ "!" head? not ] filter
@ -19,7 +17,9 @@ IN: colors.constants
[ parse-color ] H{ } map>assoc ;
MEMO: rgb.txt ( -- assoc )
"resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
"resource:basis/colors/constants/rgb.txt"
"resource:basis/colors/constants/factor-colors.txt"
[ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ;
PRIVATE>

5
basis/colors/constants/factor-colors.txt Normal file
View File

@ -0,0 +1,5 @@
! Factor UI theme colors
227 226 219 FactorLightTan
172 167 147 FactorDarkTan
81 91 105 FactorLightSlateBlue
55 62 72 FactorDarkSlateBlue

34
basis/combinators/short-circuit/short-circuit.factor
View File

@ -1,15 +1,15 @@
USING: kernel combinators quotations arrays sequences assocs
locals generalizations macros fry ;
generalizations macros fry ;
IN: combinators.short-circuit
MACRO:: n&& ( quots n -- quot )
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup not ] ]
[ '[ drop _ ndrop f ] ]
bi 2array
] map
n '[ _ nnip ] suffix 1array
MACRO: n&& ( quots n -- quot )
[
[ [ f ] ] 2dip swap [
[ '[ drop _ ndup @ dup not ] ]
[ drop '[ drop _ ndrop f ] ]
2bi 2array
] with map
] [ '[ _ nnip ] suffix 1array ] bi
[ cond ] 3append ;
<PRIVATE
@ -24,14 +24,14 @@ PRIVATE>
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
MACRO:: n|| ( quots n -- quot )
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup ] ]
[ '[ _ nnip ] ]
bi 2array
] map
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
MACRO: n|| ( quots n -- quot )
[
[ [ f ] ] 2dip swap [
[ '[ drop _ ndup @ dup ] ]
[ drop '[ _ nnip ] ]
2bi 2array
] with map
] [ '[ drop _ ndrop t ] [ f ] 2array suffix 1array ] bi
[ cond ] 3append ;
<PRIVATE

15
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes cpu.architecture compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
accessors vectors combinators sets classes cpu.architecture
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.def-use compiler.cfg.copy-prop compiler.cfg.rpo
compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
@ -211,12 +212,12 @@ M: ##alien-global insn-object drop \ ##alien-global ;
GENERIC: analyze-aliases* ( insn -- insn' )
M: insn analyze-aliases*
dup defs-vreg [ set-heap-ac ] when* ;
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: ##flushable analyze-aliases*
dup dst>> set-heap-ac ;
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
@ -246,8 +247,6 @@ M: ##copy analyze-aliases*
#! vreg, since they both contain the same value.
dup record-copy ;
M: insn analyze-aliases* ;
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;

14
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -189,5 +189,17 @@ IN: compiler.cfg.builder.tests
[ f t ] [
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
[ [ ##slot-imm? ] contains-insn? ] bi
[ [ ##unbox-alien? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test

2
basis/compiler/cfg/builder/builder.factor
View File

@ -131,7 +131,7 @@ M: #recursive emit-node
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{

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

@ -21,8 +21,9 @@ ERROR: last-insn-not-a-jump bb ;
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
[ ##conditional-branch? ]
[ ##compare-branch? ]
[ ##compare-imm-branch? ]
[ ##compare-float-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]

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

@ -42,14 +42,11 @@ M: ##set-slot-imm build-liveness-graph
M: ##write-barrier build-liveness-graph
dup src>> setter-liveness-graph ;
M: ##flushable build-liveness-graph
dup dst>> add-edges ;
M: ##allot build-liveness-graph
[ dst>> allocations get conjoin ]
[ call-next-method ] bi ;
[ dst>> allocations get conjoin ] [ call-next-method ] bi ;
M: insn build-liveness-graph drop ;
M: insn build-liveness-graph
dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
GENERIC: compute-live-vregs ( insn -- )
@ -77,24 +74,35 @@ M: ##set-slot-imm compute-live-vregs
M: ##write-barrier compute-live-vregs
dup src>> setter-live-vregs ;
M: ##flushable compute-live-vregs drop ;
M: ##fixnum-add compute-live-vregs record-live ;
M: ##fixnum-sub compute-live-vregs record-live ;
M: ##fixnum-mul compute-live-vregs record-live ;
M: insn compute-live-vregs
record-live ;
dup defs-vreg [ drop ] [ record-live ] if ;
GENERIC: live-insn? ( insn -- ? )
M: ##flushable live-insn? dst>> live-vreg? ;
M: ##set-slot live-insn? obj>> live-vreg? ;
M: ##set-slot-imm live-insn? obj>> live-vreg? ;
M: ##write-barrier live-insn? src>> live-vreg? ;
M: insn live-insn? drop t ;
M: ##fixnum-add live-insn? drop t ;
M: ##fixnum-sub live-insn? drop t ;
M: ##fixnum-mul live-insn? drop t ;
M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
: eliminate-dead-code ( cfg -- cfg' )
! Even though we don't use predecessors directly, we depend
! on the predecessors pass updating phi nodes to remove dead
! inputs.
needs-predecessors
init-dead-code

83
basis/compiler/cfg/def-use/def-use.factor
View File

@ -1,55 +1,52 @@
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel assocs sequences namespaces fry
sets compiler.cfg.rpo compiler.cfg.instructions locals ;
USING: accessors assocs arrays classes combinators
compiler.units fry generalizations generic kernel locals
namespaces quotations sequences sets slots words
compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.rpo ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vreg dst>> ;
M: ##fixnum-overflow defs-vreg dst>> ;
M: _fixnum-overflow defs-vreg dst>> ;
M: insn defs-vreg drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp temp-vregs temp>> 1array ;
M: ##allot temp-vregs temp>> 1array ;
M: ##dispatch temp-vregs temp>> 1array ;
M: ##slot temp-vregs temp>> 1array ;
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ;
M: ##effect uses-vregs src>> 1array ;
M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> values ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ;
<PRIVATE
: slot-array-quot ( slots -- quot )
[ reader-word 1quotation ] map dup length {
{ 0 [ drop [ drop f ] ] }
{ 1 [ first [ 1array ] compose ] }
{ 2 [ first2 '[ _ _ bi 2array ] ] }
[ '[ _ cleave _ narray ] ]
} case ;
: define-defs-vreg-method ( insn -- )
[ \ defs-vreg create-method ]
[ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
define ;
: define-uses-vregs-method ( insn -- )
[ \ uses-vregs create-method ]
[ insn-use-slots [ name>> ] map slot-array-quot ] bi
define ;
: define-temp-vregs-method ( insn -- )
[ \ temp-vregs create-method ]
[ insn-temp-slots [ name>> ] map slot-array-quot ] bi
define ;
PRIVATE>
[
insn-classes get
[ [ define-defs-vreg-method ] each ]
[ { ##phi } diff [ define-uses-vregs-method ] each ]
[ [ define-temp-vregs-method ] each ]
tri
] with-compilation-unit
! Computing def-use chains.

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

@ -1,83 +1,60 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel layouts math namespaces
sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
USING: accessors arrays byte-arrays kernel layouts math
namespaces sequences combinators splitting parser effects
words cpu.architecture compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions.syntax ;
IN: compiler.cfg.hats
: ^^r ( -- vreg vreg ) next-vreg dup ; inline
: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
<<
<PRIVATE
: hat-name ( insn -- word )
name>> "##" ?head drop "^^" prepend create-in ;
: hat-quot ( insn -- quot )
[
"insn-slots" word-prop [ ] [
type>> {
{ def [ [ next-vreg dup ] ] }
{ temp [ [ next-vreg ] ] }
[ drop [ ] ]
} case swap [ dip ] curry compose
] reduce
] keep suffix ;
: hat-effect ( insn -- effect )
"insn-slots" word-prop
[ type>> { def temp } memq? not ] filter [ name>> ] map
{ "vreg" } <effect> ;
: define-hat ( insn -- )
[ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
PRIVATE>
insn-classes get [
dup [ insn-def-slot ] [ name>> "##" head? ] bi and
[ define-hat ] [ drop ] if
] each
>>
: ^^load-literal ( obj -- dst )
[ next-vreg dup ] dip {
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
[ ##load-reference ]
} cond ; inline
: ^^unbox-c-ptr ( src class -- dst )
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
: ^^and ( input mask -- output ) ^^r2 ##and ; inline
: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
: ^^not ( src -- dst ) ^^r1 ##not ; inline
: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
: ^^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
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline
: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
: ^^box-displaced-alien ( base displacement base-class -- dst )
^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline

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

@ -1,136 +1,368 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays
compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ;
math math.order layouts classes.algebra classes.union
compiler.units alien byte-arrays compiler.constants combinators
compiler.cfg.registers compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
<<
SYMBOL: insn-classes
V{ } clone insn-classes set-global
>>
: new-insn ( ... class -- insn ) f swap boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
! Instruction with no side effects; if 'out' is never read, we
! can eliminate it.
TUPLE: ##flushable < insn dst ;
! Instruction which is referentially transparent; we can replace
! repeated computation with a reference to a previous value
TUPLE: ##pure < ##flushable ;
TUPLE: ##unary < ##pure src ;
TUPLE: ##unary/temp < ##unary temp ;
TUPLE: ##binary < ##pure src1 src2 ;
TUPLE: ##binary-imm < ##pure src1 { src2 integer } ;
TUPLE: ##commutative < ##binary ;
TUPLE: ##commutative-imm < ##binary-imm ;
! Instruction only used for its side effect, produces no values
TUPLE: ##effect < insn src ;
! Read/write ops: candidates for alias analysis
TUPLE: ##read < ##flushable ;
TUPLE: ##write < ##effect ;
TUPLE: ##alien-getter < ##flushable src ;
TUPLE: ##alien-setter < ##effect value ;
! Instructions which are referentially transparent; used for
! value numbering
TUPLE: pure-insn < insn ;
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##load-reference < ##pure obj ;
INSN: ##load-immediate
def: dst/int-rep
constant: val ;
GENERIC: ##load-literal ( dst value -- )
INSN: ##load-reference
def: dst/int-rep
constant: obj ;
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-reference ;
INSN: ##peek
def: dst/int-rep
literal: loc ;
INSN: ##peek < ##flushable { loc loc } ;
INSN: ##replace < ##effect { loc loc } ;
INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
INSN: ##replace
use: src/int-rep
literal: loc ;
INSN: ##inc-d
literal: n ;
INSN: ##inc-r
literal: n ;
! Subroutine calls
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##call
literal: word ;
INSN: ##jump
literal: word ;
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
INSN: ##no-tco ;
! Jump tables
INSN: ##dispatch src temp ;
INSN: ##dispatch
use: src/int-rep
temp: temp/int-rep ;
! Slot access
INSN: ##slot < ##read obj slot { tag integer } temp ;
INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ;
INSN: ##set-slot < ##write obj slot { tag integer } temp ;
INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ;
INSN: ##slot
def: dst/int-rep
use: obj/int-rep slot/int-rep
literal: tag
temp: temp/int-rep ;
INSN: ##slot-imm
def: dst/int-rep
use: obj/int-rep
literal: slot tag ;
INSN: ##set-slot
use: src/int-rep obj/int-rep slot/int-rep
literal: tag
temp: temp/int-rep ;
INSN: ##set-slot-imm
use: src/int-rep obj/int-rep
literal: slot tag ;
! String element access
INSN: ##string-nth < ##flushable obj index temp ;
INSN: ##set-string-nth-fast < ##effect obj index temp ;
INSN: ##string-nth
def: dst/int-rep
use: obj/int-rep index/int-rep
temp: temp/int-rep ;
INSN: ##set-string-nth-fast
use: src/int-rep obj/int-rep index/int-rep
temp: temp/int-rep ;
PURE-INSN: ##copy
def: dst
use: src
literal: rep ;
! Integer arithmetic
INSN: ##add < ##commutative ;
INSN: ##add-imm < ##commutative-imm ;
INSN: ##sub < ##binary ;
INSN: ##sub-imm < ##binary-imm ;
INSN: ##mul < ##commutative ;
INSN: ##mul-imm < ##commutative-imm ;
INSN: ##and < ##commutative ;
INSN: ##and-imm < ##commutative-imm ;
INSN: ##or < ##commutative ;
INSN: ##or-imm < ##commutative-imm ;
INSN: ##xor < ##commutative ;
INSN: ##xor-imm < ##commutative-imm ;
INSN: ##shl < ##binary ;
INSN: ##shl-imm < ##binary-imm ;
INSN: ##shr < ##binary ;
INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar < ##binary ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##min < ##binary ;
INSN: ##max < ##binary ;
INSN: ##not < ##unary ;
INSN: ##log2 < ##unary ;
PURE-INSN: ##add
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
PURE-INSN: ##add-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##sub
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##sub-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##mul
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##mul-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##and
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##and-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##or
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##or-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##xor
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##xor-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##shl
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##shl-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##shr
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##shr-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##sar
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##sar-imm
def: dst/int-rep
use: src1/int-rep
constant: src2 ;
PURE-INSN: ##min
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##max
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
PURE-INSN: ##not
def: dst/int-rep
use: src/int-rep ;
PURE-INSN: ##log2
def: dst/int-rep
use: src/int-rep ;
! Bignum/integer conversion
INSN: ##integer>bignum < ##unary/temp ;
INSN: ##bignum>integer < ##unary/temp ;
PURE-INSN: ##integer>bignum
def: dst/int-rep
use: src/int-rep
temp: temp/int-rep ;
PURE-INSN: ##bignum>integer
def: dst/int-rep
use: src/int-rep
temp: temp/int-rep ;
! Float arithmetic
INSN: ##add-float < ##commutative ;
INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ;
INSN: ##min-float < ##binary ;
INSN: ##max-float < ##binary ;
INSN: ##sqrt < ##unary ;
PURE-INSN: ##unbox-float
def: dst/double-rep
use: src/int-rep ;
PURE-INSN: ##box-float
def: dst/int-rep
use: src/double-rep
temp: temp/int-rep ;
PURE-INSN: ##add-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
PURE-INSN: ##sub-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
PURE-INSN: ##mul-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
PURE-INSN: ##div-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
PURE-INSN: ##min-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
PURE-INSN: ##max-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
PURE-INSN: ##sqrt
def: dst/double-rep
use: src/double-rep ;
! libc intrinsics
INSN: ##unary-float-function < ##unary func ;
INSN: ##binary-float-function < ##binary func ;
PURE-INSN: ##unary-float-function
def: dst/double-rep
use: src/double-rep
literal: func ;
PURE-INSN: ##binary-float-function
def: dst/double-rep
use: src1/double-rep src2/double-rep
literal: func ;
! Single/double float conversion
PURE-INSN: ##single>double-float
def: dst/double-rep
use: src/float-rep ;
PURE-INSN: ##double>single-float
def: dst/float-rep
use: src/double-rep ;
! Float/integer conversion
INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ;
PURE-INSN: ##float>integer
def: dst/int-rep
use: src/double-rep ;
! Boxing and unboxing
INSN: ##copy < ##unary rep ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
PURE-INSN: ##integer>float
def: dst/double-rep
use: src/int-rep ;
! SIMD operations
PURE-INSN: ##box-vector
def: dst/int-rep
use: src
literal: rep
temp: temp/int-rep ;
PURE-INSN: ##unbox-vector
def: dst
use: src/int-rep
literal: rep ;
PURE-INSN: ##broadcast-vector
def: dst
use: src/scalar-rep
literal: rep ;
PURE-INSN: ##gather-vector-2
def: dst
use: src1/scalar-rep src2/scalar-rep
literal: rep ;
PURE-INSN: ##gather-vector-4
def: dst
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
literal: rep ;
PURE-INSN: ##add-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##sub-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##mul-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##div-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##min-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##max-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##sqrt-vector
def: dst
use: src
literal: rep ;
PURE-INSN: ##horizontal-add-vector
def: dst/scalar-rep
use: src
literal: rep ;
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
def: dst/int-rep
use: src/int-rep
temp: temp/int-rep ;
PURE-INSN: ##box-displaced-alien
def: dst/int-rep
use: displacement/int-rep base/int-rep
temp: temp1/int-rep temp2/int-rep
literal: base-class ;
PURE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
use: src/int-rep
temp: temp/int-rep ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
PURE-INSN: ##unbox-alien
def: dst/int-rep
use: src/int-rep ;
: ##unbox-c-ptr ( dst src class temp -- )
{
@ -141,42 +373,95 @@ INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
} cond ;
! Alien accessors
INSN: ##alien-unsigned-1 < ##alien-getter ;
INSN: ##alien-unsigned-2 < ##alien-getter ;
INSN: ##alien-unsigned-4 < ##alien-getter ;
INSN: ##alien-signed-1 < ##alien-getter ;
INSN: ##alien-signed-2 < ##alien-getter ;
INSN: ##alien-signed-4 < ##alien-getter ;
INSN: ##alien-cell < ##alien-getter ;
INSN: ##alien-float < ##alien-getter ;
INSN: ##alien-double < ##alien-getter ;
INSN: ##alien-unsigned-1
def: dst/int-rep
use: src/int-rep ;
INSN: ##set-alien-integer-1 < ##alien-setter ;
INSN: ##set-alien-integer-2 < ##alien-setter ;
INSN: ##set-alien-integer-4 < ##alien-setter ;
INSN: ##set-alien-cell < ##alien-setter ;
INSN: ##set-alien-float < ##alien-setter ;
INSN: ##set-alien-double < ##alien-setter ;
INSN: ##alien-unsigned-2
def: dst/int-rep
use: src/int-rep ;
INSN: ##alien-unsigned-4
def: dst/int-rep
use: src/int-rep ;
INSN: ##alien-signed-1
def: dst/int-rep
use: src/int-rep ;
INSN: ##alien-signed-2
def: dst/int-rep
use: src/int-rep ;
INSN: ##alien-signed-4
def: dst/int-rep
use: src/int-rep ;
INSN: ##alien-cell
def: dst/int-rep
use: src/int-rep ;
INSN: ##alien-float
def: dst/float-rep
use: src/int-rep ;
INSN: ##alien-double
def: dst/double-rep
use: src/int-rep ;
INSN: ##alien-vector
def: dst
use: src/int-rep
literal: rep ;
INSN: ##set-alien-integer-1
use: src/int-rep value/int-rep ;
INSN: ##set-alien-integer-2
use: src/int-rep value/int-rep ;
INSN: ##set-alien-integer-4
use: src/int-rep value/int-rep ;
INSN: ##set-alien-cell
use: src/int-rep value/int-rep ;
INSN: ##set-alien-float
use: src/int-rep value/float-rep ;
INSN: ##set-alien-double
use: src/int-rep value/double-rep ;
INSN: ##set-alien-vector
use: src/int-rep value
literal: rep ;
! Memory allocation
INSN: ##allot < ##flushable size class temp ;
INSN: ##allot
def: dst/int-rep
literal: size class
temp: temp/int-rep ;
UNION: ##allocation
##allot
##box-float
##box-alien
##box-displaced-alien
##integer>bignum ;
INSN: ##write-barrier
use: src/int-rep
temp: card#/int-rep table/int-rep ;
INSN: ##write-barrier < ##effect card# table ;
INSN: ##alien-global < ##flushable symbol library ;
INSN: ##alien-global
def: dst/int-rep
literal: symbol library ;
! FFI
INSN: ##alien-invoke params stack-frame ;
INSN: ##alien-indirect params stack-frame ;
INSN: ##alien-callback params stack-frame ;
INSN: ##callback-return params ;
INSN: ##alien-invoke
literal: params stack-frame ;
INSN: ##alien-indirect
literal: params stack-frame ;
INSN: ##alien-callback
literal: params stack-frame ;
INSN: ##callback-return
literal: params ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
@ -184,133 +469,172 @@ INSN: ##epilogue ;
INSN: ##branch ;
INSN: ##phi < ##pure inputs ;
INSN: ##phi
def: dst
literal: inputs ;
! Conditionals
TUPLE: ##conditional-branch < insn src1 src2 cc ;
INSN: ##compare-branch
use: src1/int-rep src2/int-rep
literal: cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch src1 { src2 integer } cc ;
INSN: ##compare-imm-branch
use: src1/int-rep
constant: src2
literal: cc ;
INSN: ##compare < ##binary cc temp ;
INSN: ##compare-imm < ##binary-imm cc temp ;
PURE-INSN: ##compare
def: dst/int-rep
use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
PURE-INSN: ##compare-imm
def: dst/int-rep
use: src1/int-rep
constant: src2
literal: cc
temp: temp/int-rep ;
INSN: ##compare-float-branch
use: src1/double-rep src2/double-rep
literal: cc ;
PURE-INSN: ##compare-float
def: dst/int-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
! Overflowing arithmetic
TUPLE: ##fixnum-overflow < insn dst src1 src2 ;
INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
INSN: ##fixnum-add
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
INSN: ##fixnum-sub
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
INSN: ##fixnum-mul
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
INSN: ##gc
temp: temp1/int-rep temp2/int-rep
literal: data-values tagged-values uninitialized-locs ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ;
INSN: _prologue
literal: stack-frame ;
INSN: _label id ;
INSN: _epilogue
literal: stack-frame ;
INSN: _label
literal: label ;
INSN: _branch
literal: label ;
INSN: _branch label ;
INSN: _loop-entry ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
INSN: _dispatch
use: src/int-rep
temp: temp ;
TUPLE: _conditional-branch < insn label src1 src2 cc ;
INSN: _dispatch-label
literal: label ;
INSN: _compare-branch < _conditional-branch ;
INSN: _compare-imm-branch label src1 { src2 integer } cc ;
INSN: _compare-branch
literal: label
use: src1/int-rep src2/int-rep
literal: cc ;
INSN: _compare-float-branch < _conditional-branch ;
INSN: _compare-imm-branch
literal: label
use: src1/int-rep
constant: src2
literal: cc ;
INSN: _compare-float-branch
literal: label
use: src1/int-rep src2/int-rep
literal: cc ;
! Overflowing arithmetic
TUPLE: _fixnum-overflow < insn label dst src1 src2 ;
INSN: _fixnum-add < _fixnum-overflow ;
INSN: _fixnum-sub < _fixnum-overflow ;
INSN: _fixnum-mul < _fixnum-overflow ;
INSN: _fixnum-add
literal: label
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
INSN: _fixnum-sub
literal: label
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
INSN: _fixnum-mul
literal: label
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
INSN: _gc
temp: temp1 temp2
literal: data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
INSN: _spill src rep n ;
INSN: _reload dst rep n ;
INSN: _spill-area-size n ;
INSN: _spill
use: src
literal: rep n ;
! Instructions that use vregs
UNION: vreg-insn
##flushable
##write-barrier
##dispatch
##effect
##fixnum-overflow
##conditional-branch
##compare-imm-branch
##phi
##gc
_conditional-branch
_compare-imm-branch
_dispatch ;
INSN: _reload
def: dst
literal: rep n ;
INSN: _spill-area-size
literal: n ;
UNION: ##allocation
##allot
##box-float
##box-vector
##box-alien
##box-displaced-alien
##integer>bignum ;
! For alias analysis
UNION: ##read ##slot ##slot-imm ;
UNION: ##write ##set-slot ##set-slot-imm ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn
##unary-float-function
##binary-float-function ;
##unary-float-function
##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
##call
##prologue
##epilogue
##alien-invoke
##alien-indirect
##alien-callback ;
! Instructions that output floats
UNION: output-float-insn
##add-float
##sub-float
##mul-float
##div-float
##min-float
##max-float
##sqrt
##unary-float-function
##binary-float-function
##integer>float
##unbox-float
##alien-float
##alien-double ;
! Instructions that take floats as inputs
UNION: input-float-insn
##add-float
##sub-float
##mul-float
##div-float
##min-float
##max-float
##sqrt
##unary-float-function
##binary-float-function
##float>integer
##box-float
##set-alien-float
##set-alien-double
##compare-float
##compare-float-branch ;
! Smackdown
INTERSECTION: ##unary-float ##unary input-float-insn ;
INTERSECTION: ##binary-float ##binary input-float-insn ;
##call
##prologue
##epilogue
##alien-invoke
##alien-indirect
##alien-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
##integer>bignum
##bignum>integer
##unbox-any-c-ptr ;
##integer>bignum
##bignum>integer
##unbox-any-c-ptr ;
SYMBOL: vreg-insn
[
vreg-insn
insn-classes get [
"insn-slots" word-prop [ type>> { def use temp } memq? ] any?
] filter
define-union-class
] with-compilation-unit

86
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -1,22 +1,84 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser accessors effects ;
make fry sequences parser accessors effects namespaces
combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
SYMBOLS: def use temp literal constant ;
SYMBOL: scalar-rep
TUPLE: insn-slot-spec type name rep ;
: parse-rep ( str/f -- rep )
{
{ [ dup not ] [ ] }
{ [ dup "scalar-rep" = ] [ drop scalar-rep ] }
[ "cpu.architecture" lookup ]
} cond ;
: parse-insn-slot-spec ( type string -- spec )
over [ "Missing type" throw ] unless
"/" split1 parse-rep
insn-slot-spec boa ;
: parse-insn-slot-specs ( seq -- specs )
[
f [
{
{ "def:" [ drop def ] }
{ "use:" [ drop use ] }
{ "temp:" [ drop temp ] }
{ "literal:" [ drop literal ] }
{ "constant:" [ drop constant ] }
[ dupd parse-insn-slot-spec , ]
} case
] reduce drop
] { } make ;
: insn-def-slot ( class -- slot/f )
"insn-slots" word-prop
[ type>> def eq? ] find nip ;
: insn-use-slots ( class -- slot/f )
"insn-slots" word-prop
[ type>> use eq? ] filter ;
: insn-temp-slots ( class -- slot/f )
"insn-slots" word-prop
[ type>> temp eq? ] filter ;
! We cannot reference words in compiler.cfg.instructions directly
! since that would create circularity.
: insn-classes-word ( -- word )
"insn-classes" "compiler.cfg.instructions" lookup ;
: insn-word ( -- word )
#! We want to put the insn tuple in compiler.cfg.instructions,
#! but we cannot have circularity between that vocabulary and
#! this one.
"insn" "compiler.cfg.instructions" lookup ;
: pure-insn-word ( -- word )
"pure-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
SYNTAX: INSN:
parse-tuple-definition "insn#" suffix
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ;
: define-insn-tuple ( class superclass specs -- )
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
[ name>> ] map f <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {
[ nip "insn-slots" set-word-prop ]
[ 2drop insn-classes-word get push ]
[ define-insn-tuple ]
[ 2drop save-location ]
[ nip define-insn-ctor ]
} 3cleave ;
SYNTAX: INSN: CREATE-CLASS insn-word ";" parse-tokens define-insn ;
SYNTAX: PURE-INSN: CREATE-CLASS pure-insn-word ";" parse-tokens define-insn ;

40
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -20,22 +20,10 @@ IN: compiler.cfg.intrinsics.alien
^^box-displaced-alien ds-push
] [ emit-primitive ] if ;
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
: (prepare-alien-accessor) ( class -- offset-vreg )
[ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
dup value-info-small-fixnum? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
[ infos prepare-alien-accessor quot call ]
[ infos quot call ]
[ node emit-primitive ]
if
] ; inline
@ -45,8 +33,14 @@ IN: compiler.cfg.intrinsics.alien
[ second class>> fixnum class<= ]
bi and ;
: prepare-alien-accessor ( info -- offset-vreg )
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
: prepare-alien-getter ( infos -- offset-vreg )
first prepare-alien-accessor ;
: inline-alien-getter ( node quot -- )
'[ @ ds-push ]
'[ prepare-alien-getter @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
@ -55,19 +49,21 @@ IN: compiler.cfg.intrinsics.alien
[ third class>> fixnum class<= ]
tri and and ;
: prepare-alien-setter ( infos -- offset-vreg )
second prepare-alien-accessor ;
: inline-alien-integer-setter ( node quot -- )
'[ ds-pop ^^untag-fixnum @ ]
'[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
[ dup node-input-infos first class>> ] dip
'[ ds-pop _ ^^unbox-c-ptr @ ]
'[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
[ pinned-c-ptr inline-alien-setter? ]
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
'[ ds-pop @ ]
'[ prepare-alien-setter ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
@ -107,15 +103,15 @@ IN: compiler.cfg.intrinsics.alien
: emit-alien-float-getter ( node rep -- )
'[
_ {
{ single-float-rep [ ^^alien-float ] }
{ double-float-rep [ ^^alien-double ] }
{ float-rep [ ^^alien-float ] }
{ double-rep [ ^^alien-double ] }
} case
] inline-alien-getter ;
: emit-alien-float-setter ( node rep -- )
'[
_ {
{ single-float-rep [ ##set-alien-float ] }
{ double-float-rep [ ##set-alien-double ] }
{ float-rep [ ##set-alien-float ] }
{ double-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;

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

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math math.intervals
namespaces combinators fry arrays
cpu.architecture
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
@ -71,7 +72,7 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
[ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
[ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline

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

@ -7,6 +7,7 @@ compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.simd
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
@ -22,6 +23,7 @@ QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
QUALIFIED: math.vectors.simd.intrinsics
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
@ -91,10 +93,10 @@ 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 ] }
{ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
{ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
{ alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
{ alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
@ -142,5 +144,27 @@ IN: compiler.cfg.intrinsics
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
: enable-sse2-simd ( -- )
{
{ math.vectors.simd.intrinsics:assert-positive [ drop ] }
{ math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
{ math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
} enable-intrinsics ;
: enable-sse3-simd ( -- )
{
{ math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;

1
basis/compiler/cfg/intrinsics/simd/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

55
basis/compiler/cfg/intrinsics/simd/simd.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays fry cpu.architecture kernel
sequences compiler.tree.propagation.info
compiler.cfg.builder.blocks compiler.cfg.stacks
compiler.cfg.stacks.local compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics.alien ;
IN: compiler.cfg.intrinsics.simd
: emit-vector-op ( node quot: ( rep -- ) -- )
[ dup node-input-infos last literal>> ] dip over representation?
[ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
: emit-binary-vector-op ( node quot -- )
'[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
: emit-unary-vector-op ( node quot -- )
'[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
: emit-gather-vector-2 ( node -- )
[ ^^gather-vector-2 ] emit-binary-vector-op ;
: emit-gather-vector-4 ( node -- )
[
ds-drop
[
D 3 peek-loc
D 2 peek-loc
D 1 peek-loc
D 0 peek-loc
-4 inc-d
] dip
^^gather-vector-4
ds-push
] emit-vector-op ;
: emit-alien-vector ( node -- )
dup [
'[
ds-drop prepare-alien-getter
_ ^^alien-vector ds-push
]
[ inline-alien-getter? ] inline-alien
] with emit-vector-op ;
: emit-set-alien-vector ( node -- )
dup [
'[
ds-drop prepare-alien-setter ds-pop
_ ##set-alien-vector
]
[ byte-array inline-alien-setter? ]
inline-alien
] with emit-vector-op ;

2
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -29,7 +29,7 @@ IN: compiler.cfg.intrinsics.slots
: (emit-set-slot) ( infos -- obj-reg )
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
pick [ ^^set-slot ] dip ;
pick [ next-vreg ##set-slot ] dip ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop

2
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -135,7 +135,7 @@ M: vreg-insn assign-registers-in-insn
[
[
2dup spill-on-gc?
[ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
[ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;

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

@ -80,9 +80,9 @@ cfg new 0 >>spill-area-size cfg set
H{ } spill-slots set
H{
{ 1 single-float-rep }
{ 2 single-float-rep }
{ 3 single-float-rep }
{ 1 float-rep }
{ 2 float-rep }
{ 3 float-rep }
} representations set
[

167
basis/compiler/cfg/renaming/functor/functor.factor
View File

@ -1,9 +1,15 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors assocs kernel accessors compiler.cfg.instructions
lexer parser ;
USING: accessors arrays assocs fry functors generic.parser
kernel lexer namespaces parser sequences slots words sets
compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.renaming.functor
: slot-change-quot ( slots quot -- quot' )
'[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
[ drop ] append ;
FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
rename-insn-defs DEFINES ${NAME}-insn-defs
@ -14,155 +20,30 @@ WHERE
GENERIC: rename-insn-defs ( insn -- )
M: ##flushable rename-insn-defs
DEF-QUOT change-dst
drop ;
M: ##fixnum-overflow rename-insn-defs
DEF-QUOT change-dst
drop ;
M: _fixnum-overflow rename-insn-defs
DEF-QUOT change-dst
drop ;
M: insn rename-insn-defs drop ;
insn-classes get [
[ \ rename-insn-defs create-method-in ]
[ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
define
] each
GENERIC: rename-insn-uses ( insn -- )
M: ##effect rename-insn-uses
USE-QUOT change-src
drop ;
M: ##unary rename-insn-uses
USE-QUOT change-src
drop ;
M: ##binary rename-insn-uses
USE-QUOT change-src1
USE-QUOT change-src2
drop ;
M: ##binary-imm rename-insn-uses
USE-QUOT change-src1
drop ;
M: ##slot rename-insn-uses
USE-QUOT change-obj
USE-QUOT change-slot
drop ;
M: ##slot-imm rename-insn-uses
USE-QUOT change-obj
drop ;
M: ##set-slot rename-insn-uses
dup call-next-method
USE-QUOT change-obj
USE-QUOT change-slot
drop ;
M: ##string-nth rename-insn-uses
USE-QUOT change-obj
USE-QUOT change-index
drop ;
M: ##set-string-nth-fast rename-insn-uses
dup call-next-method
USE-QUOT change-obj
USE-QUOT change-index
drop ;
M: ##set-slot-imm rename-insn-uses
dup call-next-method
USE-QUOT change-obj
drop ;
M: ##alien-getter rename-insn-uses
dup call-next-method
USE-QUOT change-src
drop ;
M: ##alien-setter rename-insn-uses
dup call-next-method
USE-QUOT change-value
drop ;
M: ##conditional-branch rename-insn-uses
USE-QUOT change-src1
USE-QUOT change-src2
drop ;
M: ##compare-imm-branch rename-insn-uses
USE-QUOT change-src1
drop ;
M: ##dispatch rename-insn-uses
USE-QUOT change-src
drop ;
M: ##fixnum-overflow rename-insn-uses
USE-QUOT change-src1
USE-QUOT change-src2
drop ;
insn-classes get { ##phi } diff [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
] each
M: ##phi rename-insn-uses
[ USE-QUOT assoc-map ] change-inputs
drop ;
M: insn rename-insn-uses drop ;
[ USE-QUOT assoc-map ] change-inputs drop ;
GENERIC: rename-insn-temps ( insn -- )
M: ##write-barrier rename-insn-temps
TEMP-QUOT change-card#
TEMP-QUOT change-table
drop ;
M: ##unary/temp rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##allot rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##dispatch rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##slot rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##set-slot rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##string-nth rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##set-string-nth-fast rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##box-displaced-alien rename-insn-temps
TEMP-QUOT change-temp1
TEMP-QUOT change-temp2
drop ;
M: ##compare rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##compare-imm rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##compare-float rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##gc rename-insn-temps
TEMP-QUOT change-temp1
TEMP-QUOT change-temp2
drop ;
M: _dispatch rename-insn-temps
TEMP-QUOT change-temp drop ;
M: insn rename-insn-temps drop ;
insn-classes get [
[ \ rename-insn-temps create-method-in ]
[ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
define
] each
;FUNCTOR

101
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -1,66 +1,61 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays fry namespaces
cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.def-use ;
USING: kernel accessors sequences arrays fry namespaces generic
words sets combinators generalizations cpu.architecture compiler.units
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.def-use ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
M: ##flushable defs-vreg-rep drop int-rep ;
M: ##copy defs-vreg-rep rep>> ;
M: output-float-insn defs-vreg-rep drop double-float-rep ;
M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
M: _fixnum-overflow defs-vreg-rep drop int-rep ;
M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
M: insn defs-vreg-rep drop f ;
<PRIVATE
M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
M: ##unary/temp temp-vreg-reps drop { int-rep } ;
M: ##allot temp-vreg-reps drop { int-rep } ;
M: ##dispatch temp-vreg-reps drop { int-rep } ;
M: ##slot temp-vreg-reps drop { int-rep } ;
M: ##set-slot temp-vreg-reps drop { int-rep } ;
M: ##string-nth temp-vreg-reps drop { int-rep } ;
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ;
M: ##compare temp-vreg-reps drop { int-rep } ;
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
M: ##compare-float temp-vreg-reps drop { int-rep } ;
M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
M: _dispatch temp-vreg-reps drop { int-rep } ;
M: insn temp-vreg-reps drop f ;
: rep-getter-quot ( rep -- quot )
{
{ f [ [ rep>> ] ] }
{ scalar-rep [ [ rep>> scalar-rep-of ] ] }
[ [ drop ] swap suffix ]
} case ;
M: ##copy uses-vreg-reps rep>> 1array ;
M: ##unary uses-vreg-reps drop { int-rep } ;
M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
M: ##binary-imm uses-vreg-reps drop { int-rep } ;
M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
M: ##effect uses-vreg-reps drop { int-rep } ;
M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
M: ##slot-imm uses-vreg-reps drop { int-rep } ;
M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
M: ##dispatch uses-vreg-reps drop { int-rep } ;
M: ##alien-getter uses-vreg-reps drop { int-rep } ;
M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
M: _dispatch uses-vreg-reps drop { int-rep } ;
M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
M: insn uses-vreg-reps drop f ;
: define-defs-vreg-rep-method ( insn -- )
[ \ defs-vreg-rep create-method ]
[ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
bi define ;
: reps-getter-quot ( reps -- quot )
dup [ rep>> { f scalar-rep } memq? not ] all? [
[ rep>> ] map [ drop ] swap suffix
] [
[ rep>> rep-getter-quot ] map dup length {
{ 0 [ drop [ drop f ] ] }
{ 1 [ first [ 1array ] compose ] }
{ 2 [ first2 '[ _ _ bi 2array ] ] }
[ '[ _ cleave _ narray ] ]
} case
] if ;
: define-uses-vreg-reps-method ( insn -- )
[ \ uses-vreg-reps create-method ]
[ insn-use-slots reps-getter-quot ]
bi define ;
: define-temp-vreg-reps-method ( insn -- )
[ \ temp-vreg-reps create-method ]
[ insn-temp-slots reps-getter-quot ]
bi define ;
PRIVATE>
[
insn-classes get
[ [ define-defs-vreg-rep-method ] each ]
[ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
[ [ define-temp-vreg-reps-method ] each ]
tri
] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline

4
basis/compiler/cfg/representations/representations-tests.factor
View File

@ -3,7 +3,7 @@ compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.representations.preferred ;
IN: compiler.cfg.representations
[ { double-float-rep double-float-rep } ] [
[ { double-rep double-rep } ] [
T{ ##add-float
{ dst 5 }
{ src1 3 }
@ -11,7 +11,7 @@ IN: compiler.cfg.representations
} uses-vreg-reps
] unit-test
[ double-float-rep ] [
[ double-rep ] [
T{ ##alien-double
{ dst 5 }
{ src 3 }

52
basis/compiler/cfg/representations/representations.factor
View File

@ -5,6 +5,7 @@ arrays combinators make locals deques dlists
cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.def-use
@ -16,13 +17,52 @@ IN: compiler.cfg.representations
! Virtual register representation selection.
ERROR: bad-conversion dst src dst-rep src-rep ;
GENERIC: emit-box ( dst src rep -- )
GENERIC: emit-unbox ( dst src rep -- )
M: float-rep emit-box
drop
[ double-rep next-vreg-rep dup ] dip ##single>double-float
int-rep next-vreg-rep ##box-float ;
M: float-rep emit-unbox
drop
[ double-rep next-vreg-rep dup ] dip ##unbox-float
##double>single-float ;
M: double-rep emit-box
drop
int-rep next-vreg-rep ##box-float ;
M: double-rep emit-unbox
drop ##unbox-float ;
M: vector-rep emit-box
int-rep next-vreg-rep ##box-vector ;
M: vector-rep emit-unbox
##unbox-vector ;
: emit-conversion ( dst src dst-rep src-rep -- )
2array {
{ { int-rep int-rep } [ int-rep ##copy ] }
{ { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
{ { double-float-rep int-rep } [ ##unbox-float ] }
{ { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
} case ;
{
{ [ 2dup eq? ] [ drop ##copy ] }
{ [ dup int-rep eq? ] [ drop emit-unbox ] }
{ [ over int-rep eq? ] [ nip emit-box ] }
[
2dup 2array {
{ { double-rep float-rep } [ 2drop ##single>double-float ] }
{ { float-rep double-rep } [ 2drop ##double>single-float ] }
! Punning SIMD vector types? Naughty naughty! But
! it is allowed... otherwise bail out.
[
drop 2dup [ reg-class-of ] bi@ eq?
[ drop ##copy ] [ bad-conversion ] if
]
} case
]
} cond ;
<PRIVATE

14
basis/compiler/cfg/two-operand/two-operand-tests.factor
View File

@ -22,14 +22,14 @@ IN: compiler.cfg.two-operand.tests
[
V{
T{ ##copy f 1 2 double-float-rep }
T{ ##copy f 1 2 double-rep }
T{ ##sub-float f 1 1 3 }
}
] [
H{
{ 1 double-float-rep }
{ 2 double-float-rep }
{ 3 double-float-rep }
{ 1 double-rep }
{ 2 double-rep }
{ 3 double-rep }
} clone representations set
{
T{ ##sub-float f 1 2 3 }
@ -38,13 +38,13 @@ IN: compiler.cfg.two-operand.tests
[
V{
T{ ##copy f 1 2 double-float-rep }
T{ ##copy f 1 2 double-rep }
T{ ##mul-float f 1 1 1 }
}
] [
H{
{ 1 double-float-rep }
{ 2 double-float-rep }
{ 1 double-rep }
{ 2 double-rep }
} clone representations set
{
T{ ##mul-float f 1 2 2 }

12
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -37,13 +37,21 @@ UNION: two-operand-insn
##sar-imm
##min
##max
##fixnum-overflow
##fixnum-add
##fixnum-sub
##fixnum-mul
##add-float
##sub-float
##mul-float
##div-float
##min-float
##max-float ;
##max-float
##add-vector
##sub-vector
##mul-vector
##div-vector
##min-vector
##max-vector ;
GENERIC: convert-two-operand* ( insn -- )

109
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -1,23 +1,16 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes kernel math namespaces combinators
combinators.short-circuit compiler.cfg.instructions
USING: accessors classes classes.algebra classes.parser
classes.tuple combinators combinators.short-circuit fry
generic.parser kernel math namespaces quotations sequences slots
splitting words compiler.cfg.instructions
compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions
TUPLE: unary-expr < expr in ;
TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ;
TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
TUPLE: reference-expr < expr value ;
TUPLE: unary-float-function-expr < expr in func ;
TUPLE: binary-float-function-expr < expr in1 in2 func ;
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
: <constant> ( constant -- expr )
f swap constant-expr boa ; inline
C: <constant> constant-expr
M: constant-expr equal?
over constant-expr? [
@ -27,8 +20,9 @@ M: constant-expr equal?
} 2&&
] [ 2drop f ] if ;
: <reference> ( constant -- expr )
f swap reference-expr boa ; inline
TUPLE: reference-expr < expr value ;
C: <reference> reference-expr
M: reference-expr equal?
over reference-expr? [
@ -43,73 +37,42 @@ M: reference-expr equal?
GENERIC: >expr ( insn -- expr )
M: insn >expr drop next-input-expr ;
M: ##load-immediate >expr val>> <constant> ;
M: ##load-reference >expr obj>> <reference> ;
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
<<
M: ##binary >expr
[ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
binary-expr boa ;
: input-values ( slot-specs -- slot-specs' )
[ type>> { use literal constant } memq? ] filter ;
M: ##binary-imm >expr
[ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
binary-expr boa ;
: expr-class ( insn -- expr )
name>> "##" ?head drop "-expr" append create-class-in ;
M: ##commutative >expr
[ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
commutative-expr boa ;
: define-expr-class ( insn expr slot-specs -- )
[ nip expr ] dip [ name>> ] map define-tuple-class ;
M: ##commutative-imm >expr
[ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
commutative-expr boa ;
: >expr-quot ( expr slot-specs -- quot )
[
[ name>> reader-word 1quotation ]
[
type>> {
{ use [ [ vreg>vn ] ] }
{ literal [ [ ] ] }
{ constant [ [ constant>vn ] ] }
} case
] bi append
] map cleave>quot swap suffix \ boa suffix ;
: compare>expr ( insn -- expr )
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> vreg>vn ]
[ cc>> ]
} cleave compare-expr boa ; inline
: define->expr-method ( insn expr slot-specs -- )
[ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
M: ##compare >expr compare>expr ;
: handle-pure-insn ( insn -- )
[ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
[ define-expr-class ] [ define->expr-method ] 3bi ;
: compare-imm>expr ( insn -- expr )
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> constant>vn ]
[ cc>> ]
} cleave compare-expr boa ; inline
insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
M: ##compare-imm >expr compare-imm>expr ;
M: ##compare-float >expr compare>expr ;
M: ##box-displaced-alien >expr
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> vreg>vn ]
[ base-class>> ]
} cleave box-displaced-alien-expr boa ;
M: ##unary-float-function >expr
[ class ] [ src>> vreg>vn ] [ func>> ] tri
unary-float-function-expr boa ;
M: ##binary-float-function >expr
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> vreg>vn ]
[ func>> ]
} cleave
binary-float-function-expr boa ;
M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- )
0 input-expr-counter set ;
>>

5
basis/compiler/cfg/value-numbering/graph/graph.factor
View File

@ -10,7 +10,7 @@ SYMBOL: vn-counter
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
TUPLE: expr op ;
TUPLE: expr ;
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
@ -22,7 +22,7 @@ TUPLE: input-expr < expr n ;
SYMBOL: input-expr-counter
: next-input-expr ( -- expr )
f input-expr-counter counter input-expr boa ;
input-expr-counter counter input-expr boa ;
SYMBOL: vregs>vns
@ -41,5 +41,6 @@ SYMBOL: vregs>vns
: init-value-graph ( -- )
0 vn-counter set
0 input-expr-counter set
<bihash> exprs>vns set
<bihash> vregs>vns set ;

57
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -32,27 +32,30 @@ M: insn rewrite drop f ;
} 1&&
] [ drop f ] if ; inline
: general-compare-expr? ( insn -- ? )
{ [ compare-expr? ] [ compare-imm-expr? ] [ compare-float-expr? ] } 1|| ;
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
src1>> vreg>expr compare-expr?
src1>> vreg>expr general-compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
[ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
[ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
: >compare-imm-expr< ( expr -- in1 in2 cc )
[ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
[ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
: rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> {
{ \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
{ \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
} case ;
src1>> vreg>expr {
{ [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
{ [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
{ [ dup compare-float-expr? ] [ >compare-expr< \ ##compare-float-branch new-insn ] }
} cond ;
: tag-fixnum-expr? ( expr -- ? )
dup op>> \ ##shl-imm eq?
[ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
dup shl-imm-expr?
[ src2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
@ -65,7 +68,7 @@ M: insn rewrite drop f ;
tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src1>> vreg>expr src1>> vn>vreg ]
[ src2>> tagged>constant ]
[ cc>> ]
tri ; inline
@ -81,17 +84,17 @@ M: ##compare-imm rewrite-tagged-comparison
: rewrite-redundant-comparison? ( insn -- ? )
{
[ src1>> vreg>expr compare-expr? ]
[ src1>> vreg>expr general-compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
} 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
{ \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
} case
[ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
{ [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
{ [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
{ [ dup compare-float-expr? ] [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
} cond
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
ERROR: bad-comparison ;
@ -220,14 +223,11 @@ M: ##shl-imm constant-fold* drop shift ;
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
: reassociate? ( insn -- ? )
[ src1>> vreg>expr op>> ] [ class ] bi = ; inline
: reassociate ( insn op -- insn )
[
{
[ dst>> ]
[ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
[ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
[ src2>> ]
[ ]
} cleave constant-fold*
@ -237,7 +237,7 @@ M: ##shl-imm constant-fold* drop shift ;
M: ##add-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##add-imm reassociate ] }
{ [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
[ drop f ]
} cond ;
@ -261,28 +261,28 @@ M: ##mul-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
{ [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
{ [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
M: ##and-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##and-imm reassociate ] }
{ [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
M: ##or-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##or-imm reassociate ] }
{ [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
{ [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
@ -351,9 +351,6 @@ M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
: box-displaced-alien? ( expr -- ? )
op>> \ ##box-displaced-alien eq? ;
! ##box-displaced-alien f 1 2 3 <class>
! ##unbox-c-ptr 4 1 <class>
! =>
@ -369,5 +366,5 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
] { } make ;
M: ##unbox-any-c-ptr rewrite
dup src>> vreg>expr dup box-displaced-alien?
dup src>> vreg>expr dup box-displaced-alien-expr?
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;

79
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -1,33 +1,29 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions locals ;
compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
: simplify-unbox-alien ( in -- vn/expr/f )
dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
M: copy-expr simplify* src>> ;
M: unary-expr simplify*
#! Note the copy propagation: a copy always simplifies to
#! its source VN.
[ in>> vn>expr ] [ op>> ] bi {
{ \ ##copy [ ] }
{ \ ##unbox-alien [ simplify-unbox-alien ] }
{ \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
[ 2drop f ]
} case ;
: simplify-unbox-alien ( expr -- vn/expr/f )
src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
M: unbox-alien-expr simplify* simplify-unbox-alien ;
: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
[ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
: simplify-add ( expr -- vn/expr/f )
>binary-expr< {
@ -36,12 +32,18 @@ M: unary-expr simplify*
[ 2drop f ]
} cond ; inline
M: add-expr simplify* simplify-add ;
M: add-imm-expr simplify* simplify-add ;
: simplify-sub ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
M: sub-expr simplify* simplify-sub ;
M: sub-imm-expr simplify* simplify-sub ;
: simplify-mul ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-one? ] [ drop ] }
@ -49,12 +51,18 @@ M: unary-expr simplify*
[ 2drop f ]
} cond ; inline
M: mul-expr simplify* simplify-mul ;
M: mul-imm-expr simplify* simplify-mul ;
: simplify-and ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
[ 2drop f ]
} cond ; inline
M: and-expr simplify* simplify-and ;
M: and-imm-expr simplify* simplify-and ;
: simplify-or ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
@ -63,6 +71,9 @@ M: unary-expr simplify*
[ 2drop f ]
} cond ; inline
M: or-expr simplify* simplify-or ;
M: or-imm-expr simplify* simplify-or ;
: simplify-xor ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
@ -70,45 +81,31 @@ M: unary-expr simplify*
[ 2drop f ]
} cond ; inline
M: xor-expr simplify* simplify-xor ;
M: xor-imm-expr simplify* simplify-xor ;
: useless-shr? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
over shl-imm-expr?
[ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shr ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup useless-shr? ] [ drop in1>> ] }
{ [ 2dup useless-shr? ] [ drop src1>> ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
M: shr-expr simplify* simplify-shr ;
M: shr-imm-expr simplify* simplify-shr ;
: simplify-shl ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
M: binary-expr simplify*
dup op>> {
{ \ ##add [ simplify-add ] }
{ \ ##add-imm [ simplify-add ] }
{ \ ##sub [ simplify-sub ] }
{ \ ##sub-imm [ simplify-sub ] }
{ \ ##mul [ simplify-mul ] }
{ \ ##mul-imm [ simplify-mul ] }
{ \ ##and [ simplify-and ] }
{ \ ##and-imm [ simplify-and ] }
{ \ ##or [ simplify-or ] }
{ \ ##or-imm [ simplify-or ] }
{ \ ##xor [ simplify-xor ] }
{ \ ##xor-imm [ simplify-xor ] }
{ \ ##shr [ simplify-shr ] }
{ \ ##shr-imm [ simplify-shr ] }
{ \ ##sar [ simplify-shr ] }
{ \ ##sar-imm [ simplify-shr ] }
{ \ ##shl [ simplify-shl ] }
{ \ ##shl-imm [ simplify-shl ] }
[ 2drop f ]
} case ;
M: shl-expr simplify* simplify-shl ;
M: shl-imm-expr simplify* simplify-shl ;
M: box-displaced-alien-expr simplify*
[ base>> ] [ displacement>> ] bi {

15
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -6,6 +6,7 @@ cpu.architecture
sequences.deep
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
@ -16,29 +17,21 @@ IN: compiler.cfg.value-numbering
! Local value numbering.
: >copy ( insn -- insn/##copy )
dup dst>> dup vreg>vn vn>vreg
dup defs-vreg dup vreg>vn vn>vreg
2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
: rewrite-loop ( insn -- insn' )
dup rewrite [ rewrite-loop ] [ ] ?if ;
GENERIC: process-instruction ( insn -- insn' )
M: ##flushable process-instruction
dup rewrite
[ process-instruction ]
[ dup number-values >copy ] ?if ;
M: insn process-instruction
dup rewrite
[ process-instruction ] [ ] ?if ;
[ process-instruction ]
[ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
M: array process-instruction
[ process-instruction ] map ;
: value-numbering-step ( insns -- insns' )
init-value-graph
init-expressions
[ process-instruction ] map flatten ;
: value-numbering ( cfg -- cfg' )

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

@ -5,7 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes locals
source-files.errors
source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.constants
@ -67,170 +67,153 @@ SYMBOL: labels
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
! Special cases
M: ##no-tco generate-insn drop ;
M: ##load-immediate generate-insn
[ dst>> ] [ val>> ] bi %load-immediate ;
M: ##load-reference generate-insn
[ dst>> ] [ obj>> ] bi %load-reference ;
M: ##peek generate-insn
[ dst>> ] [ loc>> ] bi %peek ;
M: ##replace generate-insn
[ src>> ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ;
M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
M: ##return generate-insn drop %return ;
M: _dispatch generate-insn
[ src>> ] [ temp>> ] bi %dispatch ;
M: _dispatch-label generate-insn
label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
: >slot< ( insn -- dst obj slot tag )
{ [ dst>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
M: _prologue generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
M: ##slot generate-insn
[ >slot< ] [ temp>> ] bi %slot ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: ##slot-imm generate-insn
>slot< %slot-imm ;
M: _spill-area-size generate-insn drop ;
: >set-slot< ( insn -- src obj slot tag )
{ [ src>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
! Some meta-programming to generate simple code generators, where
! the instruction is unpacked and then a %word is called
<<
M: ##set-slot generate-insn
[ >set-slot< ] [ temp>> ] bi %set-slot ;
: insn-slot-quot ( spec -- quot )
name>> [ reader-word ] [ "label" = ] bi
[ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
M: ##set-slot-imm generate-insn
>set-slot< %set-slot-imm ;
: codegen-method-body ( class word -- quot )
[
"insn-slots" word-prop
[ insn-slot-quot ] map cleave>quot
] dip suffix ;
M: ##string-nth generate-insn
{ [ dst>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %string-nth ;
SYNTAX: CODEGEN:
scan-word [ \ generate-insn create-method-in ] keep scan-word
codegen-method-body define ;
>>
M: ##set-string-nth-fast generate-insn
{ [ src>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %set-string-nth-fast ;
CODEGEN: ##load-immediate %load-immediate
CODEGEN: ##load-reference %load-reference
CODEGEN: ##peek %peek
CODEGEN: ##replace %replace
CODEGEN: ##inc-d %inc-d
CODEGEN: ##inc-r %inc-r
CODEGEN: ##return %return
CODEGEN: ##slot %slot
CODEGEN: ##slot-imm %slot-imm
CODEGEN: ##set-slot %set-slot
CODEGEN: ##set-slot-imm %set-slot-imm
CODEGEN: ##string-nth %string-nth
CODEGEN: ##set-string-nth-fast %set-string-nth-fast
CODEGEN: ##add %add
CODEGEN: ##add-imm %add-imm
CODEGEN: ##sub %sub
CODEGEN: ##sub-imm %sub-imm
CODEGEN: ##mul %mul
CODEGEN: ##mul-imm %mul-imm
CODEGEN: ##and %and
CODEGEN: ##and-imm %and-imm
CODEGEN: ##or %or
CODEGEN: ##or-imm %or-imm
CODEGEN: ##xor %xor
CODEGEN: ##xor-imm %xor-imm
CODEGEN: ##shl %shl
CODEGEN: ##shl-imm %shl-imm
CODEGEN: ##shr %shr
CODEGEN: ##shr-imm %shr-imm
CODEGEN: ##sar %sar
CODEGEN: ##sar-imm %sar-imm
CODEGEN: ##min %min
CODEGEN: ##max %max
CODEGEN: ##not %not
CODEGEN: ##log2 %log2
CODEGEN: ##copy %copy
CODEGEN: ##integer>bignum %integer>bignum
CODEGEN: ##bignum>integer %bignum>integer
CODEGEN: ##unbox-float %unbox-float
CODEGEN: ##box-float %box-float
CODEGEN: ##add-float %add-float
CODEGEN: ##sub-float %sub-float
CODEGEN: ##mul-float %mul-float
CODEGEN: ##div-float %div-float
CODEGEN: ##min-float %min-float
CODEGEN: ##max-float %max-float
CODEGEN: ##sqrt %sqrt
CODEGEN: ##unary-float-function %unary-float-function
CODEGEN: ##binary-float-function %binary-float-function
CODEGEN: ##single>double-float %single>double-float
CODEGEN: ##double>single-float %double>single-float
CODEGEN: ##integer>float %integer>float
CODEGEN: ##float>integer %float>integer
CODEGEN: ##unbox-vector %unbox-vector
CODEGEN: ##broadcast-vector %broadcast-vector
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
CODEGEN: ##box-vector %box-vector
CODEGEN: ##add-vector %add-vector
CODEGEN: ##sub-vector %sub-vector
CODEGEN: ##mul-vector %mul-vector
CODEGEN: ##div-vector %div-vector
CODEGEN: ##min-vector %min-vector
CODEGEN: ##max-vector %max-vector
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
CODEGEN: ##alien-unsigned-4 %alien-unsigned-4
CODEGEN: ##alien-signed-1 %alien-signed-1
CODEGEN: ##alien-signed-2 %alien-signed-2
CODEGEN: ##alien-signed-4 %alien-signed-4
CODEGEN: ##alien-cell %alien-cell
CODEGEN: ##alien-float %alien-float
CODEGEN: ##alien-double %alien-double
CODEGEN: ##alien-vector %alien-vector
CODEGEN: ##set-alien-integer-1 %set-alien-integer-1
CODEGEN: ##set-alien-integer-2 %set-alien-integer-2
CODEGEN: ##set-alien-integer-4 %set-alien-integer-4
CODEGEN: ##set-alien-cell %set-alien-cell
CODEGEN: ##set-alien-float %set-alien-float
CODEGEN: ##set-alien-double %set-alien-double
CODEGEN: ##set-alien-vector %set-alien-vector
CODEGEN: ##allot %allot
CODEGEN: ##write-barrier %write-barrier
CODEGEN: ##compare %compare
CODEGEN: ##compare-imm %compare-imm
CODEGEN: ##compare-float %compare-float
: dst/src ( insn -- dst src )
[ dst>> ] [ src>> ] bi ; inline
CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub
CODEGEN: _fixnum-mul %fixnum-mul
CODEGEN: _label resolve-label
CODEGEN: _branch %jump-label
CODEGEN: _compare-branch %compare-branch
CODEGEN: _compare-imm-branch %compare-imm-branch
CODEGEN: _compare-float-branch %compare-float-branch
CODEGEN: _dispatch %dispatch
CODEGEN: _spill %spill
CODEGEN: _reload %reload
: dst/src1/src2 ( insn -- dst src1 src2 )
[ dst>> ] [ src1>> ] [ src2>> ] tri ; inline
M: ##add generate-insn dst/src1/src2 %add ;
M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
M: ##sub generate-insn dst/src1/src2 %sub ;
M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
M: ##mul generate-insn dst/src1/src2 %mul ;
M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
M: ##and generate-insn dst/src1/src2 %and ;
M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
M: ##or generate-insn dst/src1/src2 %or ;
M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
M: ##xor generate-insn dst/src1/src2 %xor ;
M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
M: ##shl generate-insn dst/src1/src2 %shl ;
M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
M: ##shr generate-insn dst/src1/src2 %shr ;
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
M: ##sar generate-insn dst/src1/src2 %sar ;
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##min generate-insn dst/src1/src2 %min ;
M: ##max generate-insn dst/src1/src2 %max ;
M: ##not generate-insn dst/src %not ;
M: ##log2 generate-insn dst/src %log2 ;
: label/dst/src1/src2 ( insn -- label dst src1 src2 )
[ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> ] bi ; inline
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
M: ##add-float generate-insn dst/src1/src2 %add-float ;
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: ##min-float generate-insn dst/src1/src2 %min-float ;
M: ##max-float generate-insn dst/src1/src2 %max-float ;
M: ##sqrt generate-insn dst/src %sqrt ;
M: ##unary-float-function generate-insn
[ dst/src ] [ func>> ] bi %unary-float-function ;
M: ##binary-float-function generate-insn
[ dst/src1/src2 ] [ func>> ] bi %binary-float-function ;
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
M: ##box-float generate-insn dst/src/temp %box-float ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-displaced-alien generate-insn
[ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
M: ##alien-cell generate-insn dst/src %alien-cell ;
M: ##alien-float generate-insn dst/src %alien-float ;
M: ##alien-double generate-insn dst/src %alien-double ;
: >alien-setter< ( insn -- src value )
[ src>> ] [ value>> ] bi ; inline
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
M: ##allot generate-insn
{
[ dst>> ]
[ size>> ]
[ class>> ]
[ temp>> ]
} cleave
%allot ;
M: ##write-barrier generate-insn
[ src>> ]
[ card#>> ]
[ table>> ]
tri %write-barrier ;
! GC checks
! ##gc
: wipe-locs ( locs temp -- )
'[
_
@ -241,7 +224,7 @@ M: ##write-barrier generate-insn
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
temp operand n>> int-rep %reload
temp int-rep operand n>> %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
@ -254,7 +237,7 @@ GENERIC# load-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
temp operand n>> int-rep %spill ;
temp int-rep operand n>> %spill ;
M: object load-gc-root drop %load-gc-root ;
@ -296,10 +279,10 @@ GENERIC: next-fastcall-param ( rep -- )
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
M: single-float-rep next-fastcall-param
M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
M: double-float-rep next-fastcall-param
M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
GENERIC: reg-class-full? ( reg-class -- ? )
@ -497,53 +480,3 @@ M: ##alien-callback generate-insn
[ wrap-callback-quot %alien-callback ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
M: _prologue generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
id>> lookup-label resolve-label ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
: >compare< ( insn -- dst temp cc src1 src2 )
{
[ dst>> ]
[ temp>> ]
[ cc>> ]
[ src1>> ]
[ src2>> ]
} cleave ; inline
M: ##compare generate-insn >compare< %compare ;
M: ##compare-imm generate-insn >compare< %compare-imm ;
M: ##compare-float generate-insn >compare< %compare-float ;
: >binary-branch< ( insn -- label cc src1 src2 )
{
[ label>> lookup-label ]
[ cc>> ]
[ src1>> ]
[ src2>> ]
} cleave ; inline
M: _compare-branch generate-insn
>binary-branch< %compare-branch ;
M: _compare-imm-branch generate-insn
>binary-branch< %compare-imm-branch ;
M: _compare-float-branch generate-insn
>binary-branch< %compare-float-branch ;
M: _spill generate-insn
[ src>> ] [ n>> ] [ rep>> ] tri %spill ;
M: _reload generate-insn
[ dst>> ] [ n>> ] [ rep>> ] tri %reload ;
M: _spill-area-size generate-insn drop ;

4
basis/compiler/tests/codegen.factor
View File

@ -412,4 +412,6 @@ cell 4 = [
[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test

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

@ -53,7 +53,7 @@ IN: compiler.tests.low-level-ir
V{
T{ ##load-reference f 4 1.5 }
T{ ##unbox-float f 1 4 }
T{ ##copy f 2 1 double-float-rep }
T{ ##copy f 2 1 double-rep }
T{ ##box-float f 3 2 }
T{ ##copy f 0 3 int-rep }
} compile-test-bb

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -31,7 +31,7 @@ M: #branch remove-dead-code*
pad-with-bottom >>phi-in-d drop ;
: live-value-indices ( values -- indices )
[ length ] keep live-values get
[ length iota ] keep live-values get
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )

10
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
View File

@ -47,9 +47,15 @@ IN: compiler.tree.propagation.call-effect.tests
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
! This should not hang
[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
! This should get inlined, because the parameter to the curry is literal even though
! [ boa ] by itself doesn't infer
TUPLE: a-tuple x ;
[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test

84
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -50,12 +50,12 @@ M: curry cached-effect
M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
: safe-infer ( quot -- effect )
[ infer ] [ 2drop +unknown+ ] recover ;
M: quotation cached-effect
dup cached-effect>>
[ ] [
[ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
(>>cached-effect)
] ?if ;
[ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
@ -116,6 +116,29 @@ M: quotation cached-effect
: execute-effect>quot ( effect -- quot )
inline-cache new '[ drop _ _ execute-effect-ic ] ;
! Some bookkeeping to make sure that crap like
! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
! doesn't hang the compiler.
GENERIC: already-inlined-quot? ( quot -- ? )
M: curry already-inlined-quot? quot>> already-inlined-quot? ;
M: compose already-inlined-quot?
[ first>> already-inlined-quot? ]
[ second>> already-inlined-quot? ] bi or ;
M: quotation already-inlined-quot? already-inlined? ;
GENERIC: add-quot-to-history ( quot -- )
M: curry add-quot-to-history quot>> add-quot-to-history ;
M: compose add-quot-to-history
[ first>> add-quot-to-history ]
[ second>> add-quot-to-history ] bi ;
M: quotation add-quot-to-history add-to-history ;
: last2 ( seq -- penultimate ultimate )
2 tail* first2 ;
@ -129,22 +152,18 @@ ERROR: uninferable ;
(( -- object )) swap compose-effects ;
: (infer-value) ( value-info -- effect )
dup class>> {
{ \ quotation [
literal>> [ uninferable ] unless*
dup already-inlined? [ uninferable ] when
cached-effect dup +unknown+ = [ uninferable ] when
] }
{ \ curry [
slots>> third (infer-value)
remove-effect-input
] }
{ \ compose [
slots>> last2 [ (infer-value) ] bi@
compose-effects
] }
[ uninferable ]
} case ;
dup literal?>> [
literal>>
[ callable? [ uninferable ] unless ]
[ already-inlined-quot? [ uninferable ] when ]
[ safe-infer dup +unknown+ = [ uninferable ] when ] tri
] [
dup class>> {
{ \ curry [ slots>> third (infer-value) remove-effect-input ] }
{ \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
[ uninferable ]
} case
] if ;
: infer-value ( value-info -- effect/f )
[ (infer-value) ]
@ -152,17 +171,20 @@ ERROR: uninferable ;
recover ;
: (value>quot) ( value-info -- quot )
dup class>> {
{ \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
] }
{ \ compose [
slots>> last2 [ (value>quot) ] bi@
'[ [ first>> @ ] [ second>> @ ] bi ]
] }
} case ;
dup literal?>> [
literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
] [
dup class>> {
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
] }
{ \ compose [
slots>> last2 [ (value>quot) ] bi@
'[ [ first>> @ ] [ second>> @ ] bi ]
] }
} case
] if ;
: value>quot ( value-info -- quot: ( code effect -- ) )
(value>quot) '[ drop @ ] ;

14
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -97,11 +97,9 @@ SYMBOL: history
:: inline-word ( #call word -- ? )
word already-inlined? [ f ] [
#call word splicing-body [
[
word add-to-history
dup (propagate)
] with-scope
#call (>>body) t
word add-to-history
#call (>>body)
#call propagate-body
] [ f ] if*
] if ;
@ -141,5 +139,7 @@ SYMBOL: history
#! Note the logic here: if there's a custom inlining hook,
#! it is permitted to return f, which means that we try the
#! normal inlining heuristic.
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
[ 2drop t ] [ (do-inlining) ] if ;
[
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
[ 2drop t ] [ (do-inlining) ] if
] with-scope ;

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

@ -7,7 +7,7 @@ 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
generic quotations alien
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
@ -16,7 +16,8 @@ compiler.tree.propagation.slots
compiler.tree.propagation.simple
compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect
compiler.tree.propagation.transforms ;
compiler.tree.propagation.transforms
compiler.tree.propagation.simd ;
IN: compiler.tree.propagation.known-words
{ + - * / }
@ -263,6 +264,10 @@ generic-comparison-ops [
'[ 2drop _ ] "outputs" set-word-prop
] each
\ alien-cell [
2drop simple-alien \ f class-or <class-info>
] "outputs" set-word-prop
{ <tuple> <tuple-boa> } [
[
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
@ -275,9 +280,12 @@ generic-comparison-ops [
] "outputs" set-word-prop
! the output of clone has the same type as the input
: cloned-value-info ( value-info -- value-info' )
clone f >>literal f >>literal?
[ [ dup [ cloned-value-info ] when ] map ] change-slots ;
{ clone (clone) } [
[ clone f >>literal f >>literal? ]
"outputs" set-word-prop
[ cloned-value-info ] "outputs" set-word-prop
] each
\ slot [

21
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
math.intervals quotations effects ;
math.intervals quotations effects alien ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
@ -799,3 +799,22 @@ SYMBOL: not-an-assoc
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
! Type function for 'clone' had a subtle issue
TUPLE: tuple-with-read-only-slot { x read-only } ;
M: tuple-with-read-only-slot clone
x>> clone tuple-with-read-only-slot boa ; inline
[ V{ object } ] [
[ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
] unit-test
! alien-cell outputs a simple-alien or f
[ t ] [
[ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
first simple-alien class=
] unit-test
! Don't crash if bad literal inputs are passed to unsafe words
[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test

52
basis/compiler/tree/propagation/simd/simd.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays combinators fry
compiler.tree.propagation.info cpu.architecture kernel words math
math.intervals math.vectors.simd.intrinsics ;
IN: compiler.tree.propagation.simd
\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
\ (simd-sum) [
nip dup literal?>> [
literal>> scalar-rep-of {
{ float-rep [ float ] }
{ double-rep [ float ] }
} case
] [ drop real ] if
<class-info>
] "outputs" set-word-prop
\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
\ assert-positive [
real [0,inf] <class/interval-info> value-info-intersect
] "outputs" set-word-prop
\ alien-vector { byte-array } "default-output-classes" set-word-prop
! If SIMD is not available, inline alien-vector and set-alien-vector
! to get a speedup
: inline-unless-intrinsic ( word -- )
dup '[ drop _ dup "intrinsic" word-prop [ drop f ] [ def>> ] if ]
"custom-inlining" set-word-prop ;
\ alien-vector inline-unless-intrinsic
\ set-alien-vector inline-unless-intrinsic

26
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays alien.c-types
math math.private slots generic definitions
stack-checker.state
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators
combinators.short-circuit classes classes.tuple
classes.tuple.private continuations arrays alien.c-types math
math.private slots generic definitions stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -63,9 +63,19 @@ M: #declare propagate-before
[ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
: literal-inputs? ( #call -- ? )
in-d>> [ value-info literal?>> ] all? ;
: input-classes-match? ( #call word -- ? )
[ in-d>> ] [ "input-classes" word-prop ] bi*
[ [ value-info literal>> ] dip instance? ] 2all? ;
: foldable-call? ( #call word -- ? )
"foldable" word-prop
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
{
[ nip "foldable" word-prop ]
[ drop literal-inputs? ]
[ input-classes-match? ]
} 2&& ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*

4
basis/core-foundation/fsevents/fsevents.factor Normal file → Executable file
View File

@ -3,8 +3,8 @@
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
arrays specialized-arrays.direct.alien classes.struct
specialized-arrays.direct.int specialized-arrays.direct.longlong
arrays specialized-arrays.alien classes.struct
specialized-arrays.int specialized-arrays.longlong
core-foundation core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents

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

@ -18,9 +18,36 @@ SINGLETONS: tagged-rep int-rep ;
! Floating point registers can contain data with
! one of these representations
SINGLETONS: single-float-rep double-float-rep ;
SINGLETONS: float-rep double-rep ;
UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ;
! On x86, floating point registers are really vector registers
SINGLETONS:
float-4-rep
double-2-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
uint-4-rep ;
UNION: vector-rep
float-4-rep
double-2-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
uint-4-rep ;
UNION: representation
any-rep
tagged-rep
int-rep
float-rep
double-rep
vector-rep ;
! Register classes
SINGLETONS: int-regs float-regs ;
@ -31,23 +58,28 @@ CONSTANT: reg-classes { int-regs float-regs }
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
: reg-class-of ( rep -- reg-class )
{
{ tagged-rep [ int-regs ] }
{ int-rep [ int-regs ] }
{ single-float-rep [ float-regs ] }
{ double-float-rep [ float-regs ] }
{ stack-params [ stack-params ] }
} case ;
GENERIC: reg-class-of ( rep -- reg-class )
: rep-size ( rep -- n )
{
{ tagged-rep [ cell ] }
{ int-rep [ cell ] }
{ single-float-rep [ 4 ] }
{ double-float-rep [ 8 ] }
{ stack-params [ cell ] }
} case ;
M: tagged-rep reg-class-of drop int-regs ;
M: int-rep reg-class-of drop int-regs ;
M: float-rep reg-class-of drop float-regs ;
M: double-rep reg-class-of drop float-regs ;
M: vector-rep reg-class-of drop float-regs ;
M: stack-params reg-class-of drop stack-params ;
GENERIC: rep-size ( rep -- n ) foldable
M: tagged-rep rep-size drop cell ;
M: int-rep rep-size drop cell ;
M: float-rep rep-size drop 4 ;
M: double-rep rep-size drop 8 ;
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
GENERIC: scalar-rep-of ( rep -- rep' )
M: float-4-rep scalar-rep-of drop float-rep ;
M: double-2-rep scalar-rep-of drop double-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
@ -101,6 +133,8 @@ HOOK: %max cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
HOOK: %copy cpu ( dst src rep -- )
HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
@ -108,6 +142,9 @@ HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
@ -118,15 +155,32 @@ HOOK: %sqrt cpu ( dst src -- )
HOOK: %unary-float-function cpu ( dst src func -- )
HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
HOOK: %single>double-float cpu ( dst src -- )
HOOK: %double>single-float cpu ( dst src -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
HOOK: %copy cpu ( dst src rep -- )
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-vector cpu ( dst src temp rep -- )
HOOK: %unbox-vector cpu ( dst src rep -- )
HOOK: %broadcast-vector cpu ( dst src rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
HOOK: %add-vector cpu ( dst src1 src2 rep -- )
HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
HOOK: %div-vector cpu ( dst src1 src2 rep -- )
HOOK: %min-vector cpu ( dst src1 src2 rep -- )
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
HOOK: %horizontal-add-vector cpu ( dst src rep -- )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
@ -137,6 +191,7 @@ HOOK: %alien-signed-4 cpu ( dst src -- )
HOOK: %alien-cell cpu ( dst src -- )
HOOK: %alien-float cpu ( dst src -- )
HOOK: %alien-double cpu ( dst src -- )
HOOK: %alien-vector cpu ( dst src rep -- )
HOOK: %set-alien-integer-1 cpu ( ptr value -- )
HOOK: %set-alien-integer-2 cpu ( ptr value -- )
@ -144,6 +199,7 @@ HOOK: %set-alien-integer-4 cpu ( ptr value -- )
HOOK: %set-alien-cell cpu ( ptr value -- )
HOOK: %set-alien-float cpu ( ptr value -- )
HOOK: %set-alien-double cpu ( ptr value -- )
HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
@ -167,8 +223,8 @@ HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
HOOK: %spill cpu ( src n rep -- )
HOOK: %reload cpu ( dst n rep -- )
HOOK: %spill cpu ( src rep n -- )
HOOK: %reload cpu ( dst rep n -- )
HOOK: %loop-entry cpu ( -- )

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

@ -272,7 +272,7 @@ M:: ppc %float>integer ( dst src -- )
M: ppc %copy ( dst src rep -- )
{
{ int-rep [ MR ] }
{ double-float-rep [ FMR ] }
{ double-rep [ FMR ] }
} case ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
@ -352,7 +352,7 @@ M:: ppc %box-alien ( dst src temp -- )
"f" resolve-label
] with-scope ;
M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
"alloc" define-label
@ -501,7 +501,7 @@ M: ppc %epilogue ( n -- )
dst \ t %load-reference
"end" get resolve-label ; inline
:: %boolean ( dst temp cc -- )
:: %boolean ( dst cc temp -- )
cc negate-cc order-cc {
{ cc< [ dst temp \ BLT f (%boolean) ] }
{ cc<= [ dst temp \ BLE f (%boolean) ] }
@ -516,7 +516,7 @@ M: ppc %epilogue ( n -- )
: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
:: (%compare-float) ( cc src1 src2 -- branch1 branch2 )
:: (%compare-float) ( src1 src2 cc -- branch1 branch2 )
cc {
{ cc< [ src1 src2 (%compare-float-ordered) \ BLT f ] }
{ cc<= [ src1 src2 (%compare-float-ordered) \ BLT \ BEQ ] }
@ -534,9 +534,11 @@ M: ppc %epilogue ( n -- )
{ cc/<>= [ src1 src2 (%compare-float-unordered) \ BO f ] }
} case ; inline
M: ppc %compare (%compare) %boolean ;
M: ppc %compare-imm (%compare-imm) %boolean ;
M:: ppc %compare-float ( dst temp cc src1 src2 -- )
M: ppc %compare [ (%compare) ] 2dip %boolean ;
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
M:: ppc %compare-float ( dst src1 src2 cc temp -- )
cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
dst temp branch1 branch2 (%boolean) ;
@ -550,9 +552,11 @@ M:: ppc %compare-float ( dst temp cc src1 src2 -- )
{ cc/= [ label BNE ] }
} case ;
M: ppc %compare-branch (%compare) %branch ;
M: ppc %compare-imm-branch (%compare-imm) %branch ;
M:: ppc %compare-float-branch ( label cc src1 src2 -- )
M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
M:: ppc %compare-float-branch ( label src1 src2 cc -- )
cc src1 src2 (%compare-float) :> branch2 :> branch1
label branch1 execute( label -- )
branch2 [ label branch2 execute( label -- ) ] when ;
@ -560,8 +564,8 @@ M:: ppc %compare-float-branch ( label cc src1 src2 -- )
: load-from-frame ( dst n rep -- )
{
{ int-rep [ [ 1 ] dip LWZ ] }
{ single-float-rep [ [ 1 ] dip LFS ] }
{ double-float-rep [ [ 1 ] dip LFD ] }
{ float-rep [ [ 1 ] dip LFS ] }
{ double-rep [ [ 1 ] dip LFD ] }
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
} case ;
@ -570,16 +574,16 @@ M:: ppc %compare-float-branch ( label cc src1 src2 -- )
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
{ single-float-rep [ [ 1 ] dip STFS ] }
{ double-float-rep [ [ 1 ] dip STFD ] }
{ float-rep [ [ 1 ] dip STFS ] }
{ double-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
M: ppc %spill ( src n rep -- )
[ spill@ ] dip store-to-frame ;
M: ppc %spill ( src rep n -- )
swap [ spill@ ] dip store-to-frame ;
M: ppc %reload ( dst n rep -- )
[ spill@ ] dip load-from-frame ;
M: ppc %reload ( dst rep n -- )
swap [ spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;

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

@ -70,13 +70,13 @@ M: int-rep push-return-reg drop EAX PUSH ;
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
M: int-rep store-return-reg drop stack@ EAX MOV ;
M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
M: single-float-rep load-return-reg drop next-stack@ FLDS ;
M: single-float-rep store-return-reg drop stack@ FSTPS ;
M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
M: float-rep load-return-reg drop next-stack@ FLDS ;
M: float-rep store-return-reg drop stack@ FSTPS ;
M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
M: double-float-rep load-return-reg drop next-stack@ FLDL ;
M: double-float-rep store-return-reg drop stack@ FSTPL ;
M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
M: double-rep load-return-reg drop next-stack@ FLDL ;
M: double-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
@ -295,22 +295,6 @@ os windows? [
4 "double" c-type (>>align)
] unless
USING: cpu.x86.features cpu.x86.features.private ;
USE: vocabs.loader
"-no-sse2" (command-line) member? [
[ { check_sse2 } compile ] with-optimizer
"Checking if your CPU supports SSE2..." print flush
sse2? [
" - yes" print
enable-sse2
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
"You will need to bootstrap Factor again." print
flush
1 exit
] unless
] "cpu.x86" add-init-hook
] [ " - no" print ] if
] unless
"cpu.x86.features" require

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

@ -201,7 +201,7 @@ M: x86.64 %callback-value ( ctype -- )
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
: float-function-return ( reg -- )
float-regs return-reg double-float-rep copy-register ;
float-regs return-reg double-rep copy-register ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
@ -221,12 +221,11 @@ enable-alien-4-intrinsics
! Enable fast calling of libc math functions
enable-float-functions
! SSE2 is always available on x86-64.
enable-sse2
USE: vocabs.loader
{
{ [ os unix? ] [ "cpu.x86.64.unix" require ] }
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
"cpu.x86.features" require

55
basis/cpu/x86/features/features.factor
View File

@ -1,21 +1,30 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel math alien.syntax ;
USING: system kernel math math.order math.parser namespaces
alien.syntax combinators locals init io cpu.x86 compiler
compiler.units accessors ;
IN: cpu.x86.features
<PRIVATE
FUNCTION: bool check_sse2 ( ) ;
FUNCTION: int sse_version ( ) ;
FUNCTION: longlong read_timestamp_counter ( ) ;
PRIVATE>
HOOK: sse2? cpu ( -- ? )
ALIAS: sse-version sse_version
M: x86.32 sse2? check_sse2 ;
M: x86.64 sse2? t ;
: sse-string ( version -- string )
{
{ 00 [ "no SSE" ] }
{ 10 [ "SSE1" ] }
{ 20 [ "SSE2" ] }
{ 30 [ "SSE3" ] }
{ 33 [ "SSSE3" ] }
{ 41 [ "SSE4.1" ] }
{ 42 [ "SSE4.2" ] }
} case ;
HOOK: instruction-count cpu ( -- n )
@ -23,3 +32,37 @@ M: x86 instruction-count read_timestamp_counter ;
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
USING: cpu.x86.features cpu.x86.features.private ;
:: install-sse-check ( version -- )
[
sse-version version < [
"This image was built to use " write
version sse-string write
" but your CPU only supports " write
sse-version sse-string write "." print
"You will need to bootstrap Factor again." print
flush
1 exit
] when
] "cpu.x86" add-init-hook ;
: enable-sse ( version -- )
{
{ 00 [ ] }
{ 10 [ ] }
{ 20 [ enable-sse2 ] }
{ 30 [ enable-sse3 ] }
{ 33 [ enable-sse3 ] }
{ 41 [ enable-sse3 ] }
{ 42 [ enable-sse3 ] }
} case ;
[ { sse_version } compile ] with-optimizer
"Checking for multimedia extensions: " write sse-version
"sse-version" get [ string>number min ] when*
[ sse-string write " detected" print ]
[ install-sse-check ]
[ enable-sse ] tri

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

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.architecture kernel kernel.private math memory namespaces make
sequences words system layouts combinators math.order fry locals
compiler.constants
compiler.constants byte-arrays
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
@ -130,6 +130,21 @@ M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ;
M: x86 %not drop NOT ;
M: x86 %log2 BSR ;
GENERIC: copy-register* ( dst src rep -- )
M: int-rep copy-register* drop MOV ;
M: tagged-rep copy-register* drop MOV ;
M: float-rep copy-register* drop MOVSS ;
M: double-rep copy-register* drop MOVSD ;
M: float-4-rep copy-register* drop MOVUPS ;
M: double-2-rep copy-register* drop MOVUPD ;
M: vector-rep copy-register* drop MOVDQU ;
: copy-register ( dst src rep -- )
2over eq? [ 3drop ] [ copy-register* ] if ;
M: x86 %copy ( dst src rep -- ) copy-register ;
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
@ -211,24 +226,123 @@ M: x86 %min-float nip MINSD ;
M: x86 %max-float nip MAXSD ;
M: x86 %sqrt SQRTSD ;
M: x86 %single>double-float CVTSS2SD ;
M: x86 %double>single-float CVTSD2SS ;
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
GENERIC: copy-register* ( dst src rep -- )
M: int-rep copy-register* drop MOV ;
M: tagged-rep copy-register* drop MOV ;
M: single-float-rep copy-register* drop MOVSS ;
M: double-float-rep copy-register* drop MOVSD ;
: copy-register ( dst src rep -- )
2over eq? [ 3drop ] [ copy-register* ] if ;
M: x86 %copy ( dst src rep -- ) copy-register ;
M: x86 %unbox-float ( dst src -- )
float-offset [+] MOVSD ;
M:: x86 %box-float ( dst src temp -- )
dst 16 float temp %allot
dst float-offset [+] src MOVSD ;
M:: x86 %box-vector ( dst src rep temp -- )
dst rep rep-size 2 cells + byte-array temp %allot
16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
dst byte-array-offset [+]
src rep copy-register ;
M:: x86 %unbox-vector ( dst src rep -- )
dst src byte-array-offset [+]
rep copy-register ;
M: x86 %broadcast-vector ( dst src rep -- )
{
{ float-4-rep [ [ MOVAPS ] [ drop dup 0 SHUFPS ] 2bi ] }
{ double-2-rep [ [ MOVAPD ] [ drop dup 0 SHUFPD ] 2bi ] }
} case ;
M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
rep {
{
float-4-rep
[
dst src1 MOVSS
dst src2 UNPCKLPS
src3 src4 UNPCKLPS
dst src3 HEX: 44 SHUFPS
]
}
} case ;
M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
rep {
{
double-2-rep
[
dst src1 MOVAPD
dst src2 0 SHUFPD
]
}
} case ;
M: x86 %add-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ ADDPS ] }
{ double-2-rep [ ADDPD ] }
{ char-16-rep [ PADDB ] }
{ uchar-16-rep [ PADDB ] }
{ short-8-rep [ PADDW ] }
{ ushort-8-rep [ PADDW ] }
{ int-4-rep [ PADDD ] }
{ uint-4-rep [ PADDD ] }
} case drop ;
M: x86 %sub-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ SUBPS ] }
{ double-2-rep [ SUBPD ] }
{ char-16-rep [ PSUBB ] }
{ uchar-16-rep [ PSUBB ] }
{ short-8-rep [ PSUBW ] }
{ ushort-8-rep [ PSUBW ] }
{ int-4-rep [ PSUBD ] }
{ uint-4-rep [ PSUBD ] }
} case drop ;
M: x86 %mul-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ MULPS ] }
{ double-2-rep [ MULPD ] }
{ int-4-rep [ PMULLW ] }
} case drop ;
M: x86 %div-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ DIVPS ] }
{ double-2-rep [ DIVPD ] }
} case drop ;
M: x86 %min-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ MINPS ] }
{ double-2-rep [ MINPD ] }
} case drop ;
M: x86 %max-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ MAXPS ] }
{ double-2-rep [ MAXPD ] }
} case drop ;
M: x86 %sqrt-vector ( dst src rep -- )
{
{ float-4-rep [ SQRTPS ] }
{ double-2-rep [ SQRTPD ] }
} case ;
M: x86 %horizontal-add-vector ( dst src rep -- )
{
{ float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
{ double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
} case ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
@ -255,10 +369,6 @@ M:: x86 %unbox-any-c-ptr ( dst src temp -- )
"end" resolve-label
] with-scope ;
M:: x86 %box-float ( dst src temp -- )
dst 16 float temp %allot
dst float-offset [+] src MOVSD ;
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
:: %allot-alien ( dst displacement base temp -- )
@ -278,7 +388,7 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label
] with-scope ;
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
"ok" define-label
@ -405,8 +515,9 @@ M: x86 %alien-signed-2 16 %alien-signed-getter ;
M: x86 %alien-signed-4 32 %alien-signed-getter ;
M: x86 %alien-cell [] MOV ;
M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
M: x86 %alien-float [] MOVSS ;
M: x86 %alien-double [] MOVSD ;
M: x86 %alien-vector [ [] ] dip copy-register ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
@ -418,8 +529,9 @@ M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
M: x86 %set-alien-cell [ [] ] dip MOV ;
M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
M: x86 %set-alien-float [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
@ -511,7 +623,7 @@ M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
M:: x86 %compare ( dst temp cc src1 src2 -- )
M:: x86 %compare ( dst src1 src2 cc temp -- )
src1 src2 CMP
cc order-cc {
{ cc< [ dst temp \ CMOVL %boolean ] }
@ -522,7 +634,7 @@ M:: x86 %compare ( dst temp cc src1 src2 -- )
{ cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
M: x86 %compare-imm ( dst temp cc src1 src2 -- )
M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
: %cmov-float= ( dst src -- )
@ -546,7 +658,7 @@ M: x86 %compare-imm ( dst temp cc src1 src2 -- )
"no-move" resolve-label
] with-scope ;
M:: x86 %compare-float ( dst temp cc src1 src2 -- )
M:: x86 %compare-float ( dst src1 src2 cc temp -- )
cc {
{ cc< [ src2 src1 COMISD dst temp \ CMOVA %boolean ] }
{ cc<= [ src2 src1 COMISD dst temp \ CMOVAE %boolean ] }
@ -564,7 +676,7 @@ M:: x86 %compare-float ( dst temp cc src1 src2 -- )
{ cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP %boolean ] }
} case ;
M:: x86 %compare-branch ( label cc src1 src2 -- )
M:: x86 %compare-branch ( label src1 src2 cc -- )
src1 src2 CMP
cc order-cc {
{ cc< [ label JL ] }
@ -589,7 +701,7 @@ M: x86 %compare-imm-branch ( label src1 src2 cc -- )
: %jump-float/= ( label -- )
[ JNE ] [ JP ] bi ;
M:: x86 %compare-float-branch ( label cc src1 src2 -- )
M:: x86 %compare-float-branch ( label src1 src2 cc -- )
cc {
{ cc< [ src2 src1 COMISD label JA ] }
{ cc<= [ src2 src1 COMISD label JAE ] }
@ -607,8 +719,11 @@ M:: x86 %compare-float-branch ( label cc src1 src2 -- )
{ cc/<>= [ src1 src2 UCOMISD label JP ] }
} case ;
M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ;
M:: x86 %spill ( src rep n -- )
n spill@ src rep copy-register ;
M:: x86 %reload ( dst rep n -- )
dst n spill@ rep copy-register ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
@ -638,6 +753,11 @@ M: x86 small-enough? ( n -- ? )
: enable-sse2 ( -- )
enable-float-intrinsics
enable-fsqrt
enable-float-min/max ;
enable-float-min/max
enable-sse2-simd ;
: enable-sse3 ( -- )
enable-sse2
enable-sse3-simd ;
enable-min/max

2
basis/environment/winnt/winnt.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;
IN: environment.winnt
<< "TCHAR" require-c-arrays >>
<< "TCHAR" require-c-array >>
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>

2
basis/functors/functors.factor
View File

@ -130,6 +130,8 @@ SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
DEFER: ;FUNCTOR delimiter

4
basis/help/markup/markup.factor
View File

@ -87,7 +87,7 @@ ALIAS: $slot $snippet
: ($code) ( presentation quot -- )
[
snippet-style get [
code-char-style get [
last-element off
[ ($code-style) ] dip with-nesting
] with-style
@ -307,7 +307,7 @@ M: f ($instance)
: ($see) ( word quot -- )
[
snippet-style get [
code-char-style get [
code-style get swap with-nesting
] with-style
] ($block) ; inline

19
basis/help/stylesheet/stylesheet.factor
View File

@ -17,7 +17,7 @@ H{
SYMBOL: link-style
H{
{ foreground COLOR: dark-blue }
{ foreground COLOR: DodgerBlue4 }
{ font-style bold }
} link-style set-global
@ -33,7 +33,8 @@ H{
{ font-size 18 }
{ font-style bold }
{ wrap-margin 500 }
{ page-color COLOR: light-gray }
{ foreground COLOR: FactorDarkSlateBlue }
{ page-color COLOR: FactorLightTan }
{ border-width 5 }
} title-style set-global
@ -58,12 +59,18 @@ SYMBOL: snippet-style
H{
{ font-name "monospace" }
{ font-size 12 }
{ foreground COLOR: navy-blue }
{ foreground COLOR: DarkOrange4 }
} snippet-style set-global
SYMBOL: code-char-style
H{
{ font-name "monospace" }
{ font-size 12 }
} code-char-style set-global
SYMBOL: code-style
H{
{ page-color COLOR: gray80 }
{ page-color COLOR: FactorLightTan }
{ border-width 5 }
{ wrap-margin f }
} code-style set-global
@ -74,7 +81,7 @@ H{ { font-style bold } } input-style set-global
SYMBOL: url-style
H{
{ font-name "monospace" }
{ foreground COLOR: blue }
{ foreground COLOR: DodgerBlue4 }
} url-style set-global
SYMBOL: warning-style
@ -101,7 +108,7 @@ H{
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
{ table-border COLOR: light-gray }
{ table-border COLOR: FactorLightTan }
} table-style set-global
SYMBOL: list-style

11
basis/io/backend/windows/nt/nt.factor
View File

@ -14,11 +14,11 @@ TUPLE: io-callback port thread ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
"OVERLAPPED" malloc-object &free ;
OVERLAPPED malloc-struct &free ;
: make-overlapped ( port -- overlapped-ext )
[ (make-overlapped) ] dip
handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
handle>> ptr>> [ >>offset ] when* ;
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
@ -40,7 +40,7 @@ M: winnt add-completion ( win32-handle -- )
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
[ pending-overlapped get-global set-at ] curry "I/O" suspend
[ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
{
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
@ -57,11 +57,12 @@ M: winnt add-completion ( win32-handle -- )
f <void*> [ ! overlapped
us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero?
] keep *void*
] keep
*void* dup [ OVERLAPPED memory>struct ] when
] keep *int spin ;
: resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ;
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( us -- ? )
wait-for-overlapped [

2
basis/io/files/info/unix/macosx/macosx.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences
system unix io.files.unix specialized-arrays.direct.uint arrays
system unix io.files.unix specialized-arrays.uint arrays
unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
io.files.info.unix io.files.info classes.struct struct-arrays ;
IN: io.files.info.unix.macosx

4
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
ascii [ contents ] with-process-reader
ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
@ -166,7 +166,7 @@ IN: io.launcher.windows.nt.tests
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [

2
basis/io/mmap/alien/alien.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.alien ;
USING: io.mmap.functor specialized-arrays.alien ;
IN: io.mmap.alien
<< "void*" define-mapped-array >>

2
basis/io/mmap/bool/bool.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.bool ;
USING: io.mmap.functor specialized-arrays.bool ;
IN: io.mmap.bool
<< "bool" define-mapped-array >>

2
basis/io/mmap/char/char.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.char ;
USING: io.mmap.functor specialized-arrays.char ;
IN: io.mmap.char
<< "char" define-mapped-array >>

2
basis/io/mmap/double/double.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.double ;
USING: io.mmap.functor specialized-arrays.double ;
IN: io.mmap.double
<< "double" define-mapped-array >>

2
basis/io/mmap/float/float.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.float ;
USING: io.mmap.functor specialized-arrays.float ;
IN: io.mmap.float
<< "float" define-mapped-array >>

2
basis/io/mmap/int/int.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.int ;
USING: io.mmap.functor specialized-arrays.int ;
IN: io.mmap.int
<< "int" define-mapped-array >>

2
basis/io/mmap/long/long.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.long ;
USING: io.mmap.functor specialized-arrays.long ;
IN: io.mmap.long
<< "long" define-mapped-array >>

2
basis/io/mmap/longlong/longlong.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.longlong ;
USING: io.mmap.functor specialized-arrays.longlong ;
IN: io.mmap.longlong
<< "longlong" define-mapped-array >>

2
basis/io/mmap/short/short.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.short ;
USING: io.mmap.functor specialized-arrays.short ;
IN: io.mmap.short
<< "short" define-mapped-array >>

2
basis/io/mmap/uchar/uchar.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.uchar ;
USING: io.mmap.functor specialized-arrays.uchar ;
IN: io.mmap.uchar
<< "uchar" define-mapped-array >>

2
basis/io/mmap/uint/uint.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.uint ;
USING: io.mmap.functor specialized-arrays.uint ;
IN: io.mmap.uint
<< "uint" define-mapped-array >>

2
basis/io/mmap/ulong/ulong.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.ulong ;
USING: io.mmap.functor specialized-arrays.ulong ;
IN: io.mmap.ulong
<< "ulong" define-mapped-array >>

2
basis/io/mmap/ulonglong/ulonglong.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
USING: io.mmap.functor specialized-arrays.ulonglong ;
IN: io.mmap.ulonglong
<< "ulonglong" define-mapped-array >>

2
basis/io/mmap/ushort/ushort.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.ushort ;
USING: io.mmap.functor specialized-arrays.ushort ;
IN: io.mmap.ushort
<< "ushort" define-mapped-array >>

18
basis/io/monitors/linux/linux.factor
View File

@ -5,7 +5,7 @@ io.files io.pathnames io.buffers io.ports io.timeouts
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
system hashtables destructors unix ;
system hashtables destructors unix classes.struct ;
IN: io.monitors.linux
SYMBOL: watches
@ -82,30 +82,30 @@ M: linux-monitor dispose* ( monitor -- )
] { } make prune ;
: parse-event-name ( event -- name )
dup inotify-event-len zero?
[ drop "" ] [ inotify-event-name utf8 alien>string ] if ;
dup len>> zero?
[ drop "" ] [ name>> utf8 alien>string ] if ;
: parse-file-notify ( buffer -- path changed )
dup inotify-event-mask ignore-flags? [
dup mask>> ignore-flags? [
drop f f
] [
[ parse-event-name ] [ inotify-event-mask parse-action ] bi
[ parse-event-name ] [ mask>> parse-action ] bi
] if ;
: events-exhausted? ( i buffer -- ? )
fill>> >= ;
: inotify-event@ ( i buffer -- alien )
ptr>> <displaced-alien> ;
: inotify-event@ ( i buffer -- inotify-event )
ptr>> <displaced-alien> inotify-event memory>struct ;
: next-event ( i buffer -- i buffer )
2dup inotify-event@
inotify-event-len "inotify-event" heap-size +
len>> inotify-event heap-size +
swap [ + ] dip ;
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
2dup inotify-event@ dup inotify-event-wd wd>monitor
2dup inotify-event@ dup wd>> wd>monitor
[ parse-file-notify ] dip queue-change
next-event parse-file-notifications
] if ;

2
basis/math/blas/matrices/matrices.factor
View File

@ -3,9 +3,7 @@ combinators.short-circuit fry kernel locals macros
math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
specialized-arrays.complex-float specialized-arrays.complex-double
parser prettyprint.backend prettyprint.custom ascii ;
IN: math.blas.matrices

5
basis/math/blas/vectors/vectors.factor
View File

@ -3,10 +3,7 @@ combinators.short-circuit fry kernel math math.blas.ffi
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.complex-float specialized-arrays.complex-double
specialized-arrays.direct.complex-float
specialized-arrays.direct.complex-double ;
specialized-arrays.complex-float specialized-arrays.complex-double ;
IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ;

8
basis/math/constants/constants-docs.factor
View File

@ -7,7 +7,8 @@ ARTICLE: "math-constants" "Constants"
{ $subsection euler }
{ $subsection phi }
{ $subsection pi }
{ $subsection epsilon } ;
{ $subsection epsilon }
{ $subsection single-epsilon } ;
ABOUT: "math-constants"
@ -25,4 +26,7 @@ HELP: pi
{ $values { "pi" "circumference of circle with diameter 1" } } ;
HELP: epsilon
{ $values { "epsilon" "smallest floating point value you can add to 1 without underflow" } } ;
{ $values { "epsilon" "smallest double-precision floating point value you can add to 1 without underflow" } } ;
HELP: single-epsilon
{ $values { "epsilon" "smallest single-precision floating point value you can add to 1 without underflow" } } ;

3
basis/math/constants/constants.factor
View File

@ -8,6 +8,7 @@ IN: math.constants
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: 2pi ( -- pi ) 2 pi * ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
: epsilon ( -- epsilon ) HEX: 3cb0000000000000 bits>double ; foldable
: single-epsilon ( -- epsilon ) HEX: 34000000 bits>float ; foldable
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

1
basis/math/primes/factors/factors-tests.factor
View File

@ -10,3 +10,4 @@ USING: math.primes.factors sequences tools.test ;
{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
{ 24 } [ 360 divisors length ] unit-test
{ { 1 } } [ 1 divisors ] unit-test

8
basis/math/primes/factors/factors.factor
View File

@ -43,5 +43,9 @@ PRIVATE>
} cond ; foldable
: divisors ( n -- seq )
group-factors [ first2 [0,b] [ ^ ] with map ] map
[ product ] product-map natural-sort ;
dup 1 = [
1array
] [
group-factors [ first2 [0,b] [ ^ ] with map ] map
[ product ] product-map natural-sort
] if ;

69
basis/math/vectors/simd/alien/alien-tests.factor Normal file
View File

@ -0,0 +1,69 @@
IN: math.vectors.simd.alien.tests
USING: cpu.architecture math.vectors.simd
math.vectors.simd.intrinsics accessors math.vectors.simd.alien
kernel classes.struct tools.test compiler sequences byte-arrays
alien math kernel.private specialized-arrays.float combinators ;
! Vector alien intrinsics
[ float-4{ 1 2 3 4 } ] [
[
float-4{ 1 2 3 4 }
underlying>> 0 float-4-rep alien-vector
] compile-call float-4 boa
] unit-test
[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
16 [ 1 ] B{ } replicate-as 16 <byte-array>
[
0 [
{ byte-array c-ptr fixnum } declare
float-4-rep set-alien-vector
] compile-call
] keep
] unit-test
[ float-array{ 1 2 3 4 } ] [
[
float-array{ 1 2 3 4 } underlying>>
float-array{ 4 3 2 1 } clone
[ underlying>> 0 float-4-rep set-alien-vector ] keep
] compile-call
] unit-test
STRUCT: simd-struct
{ x float-4 }
{ y double-2 }
{ z double-4 }
{ w float-8 } ;
[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
[
float-4{ 1 2 3 4 }
double-2{ 2 1 }
double-4{ 4 3 2 1 }
float-8{ 1 2 3 4 5 6 7 8 }
] [
simd-struct <struct>
float-4{ 1 2 3 4 } >>x
double-2{ 2 1 } >>y
double-4{ 4 3 2 1 } >>z
float-8{ 1 2 3 4 5 6 7 8 } >>w
{ [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] unit-test
[
float-4{ 1 2 3 4 }
double-2{ 2 1 }
double-4{ 4 3 2 1 }
float-8{ 1 2 3 4 5 6 7 8 }
] [
[
simd-struct <struct>
float-4{ 1 2 3 4 } >>x
double-2{ 2 1 } >>y
double-4{ 4 3 2 1 } >>z
float-8{ 1 2 3 4 5 6 7 8 } >>w
{ [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] compile-call
] unit-test

42
basis/math/vectors/simd/alien/alien.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien accessors alien.c-types byte-arrays compiler.units
cpu.architecture locals kernel math math.vectors.simd
math.vectors.simd.intrinsics ;
IN: math.vectors.simd.alien
:: define-simd-128-type ( class rep -- )
<c-type>
byte-array >>class
class >>boxed-class
[ rep alien-vector class boa ] >>getter
[ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
16 >>size
8 >>align
rep >>rep
class name>> typedef ;
:: define-simd-256-type ( class rep -- )
<c-type>
class >>class
class >>boxed-class
[
[ rep alien-vector ]
[ 16 + >fixnum rep alien-vector ] 2bi
class boa
] >>getter
[
[ [ underlying1>> ] 2dip rep set-alien-vector ]
[ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
3bi
] >>setter
32 >>size
8 >>align
rep >>rep
class name>> typedef ;
[
float-4 float-4-rep define-simd-128-type
double-2 double-2-rep define-simd-128-type
float-8 float-4-rep define-simd-256-type
double-4 double-2-rep define-simd-256-type
] with-compilation-unit

1
basis/math/vectors/simd/alien/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/math/vectors/simd/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/math/vectors/simd/functor/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

147
basis/math/vectors/simd/functor/functor.factor Normal file
View File

@ -0,0 +1,147 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types byte-arrays classes functors
kernel math parser prettyprint.custom sequences
sequences.private literals ;
IN: math.vectors.simd.functor
ERROR: bad-length got expected ;
FUNCTOR: define-simd-128 ( T -- )
N [ 16 T heap-size /i ]
A DEFINES-CLASS ${T}-${N}
>A DEFINES >${A}
A{ DEFINES ${A}{
NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
A-rep IS ${A}-rep
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
TUPLE: A
{ underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
M: A clone underlying>> clone \ A boa ; inline
M: A length drop N ; inline
M: A nth-unsafe underlying>> NTH call ; inline
M: A set-nth-unsafe underlying>> SET-NTH call ; inline
: >A ( seq -- simd-array ) \ A new clone-like ;
M: A like drop dup \ A instance? [ >A ] unless ; inline
M: A new-sequence
drop dup N =
[ drop 16 <byte-array> \ A boa ]
[ N bad-length ]
if ; inline
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
M: A byte-length underlying>> length ; inline
M: A pprint-delims drop \ A{ \ } ;
M: A >pprint-sequence ;
M: A pprint* pprint-object ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
INSTANCE: A sequence
<PRIVATE
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
: A-v->n-op ( v quot -- n )
[ underlying>> A-rep ] dip call ; inline
PRIVATE>
;FUNCTOR
! Synthesize 256-bit vectors from a pair of 128-bit vectors
FUNCTOR: define-simd-256 ( T -- )
N [ 32 T heap-size /i ]
N/2 [ N 2 / ]
A/2 IS ${T}-${N/2}
A DEFINES-CLASS ${T}-${N}
>A DEFINES >${A}
A{ DEFINES ${A}{
A-deref DEFINES-PRIVATE ${A}-deref
A-rep IS ${A/2}-rep
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
SLOT: underlying1
SLOT: underlying2
TUPLE: A
{ underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
{ underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
M: A clone
[ underlying1>> clone ] [ underlying2>> clone ] bi
\ A boa ; inline
M: A length drop N ; inline
: A-deref ( n seq -- n' seq' )
over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
M: A nth-unsafe A-deref nth-unsafe ; inline
M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
: >A ( seq -- simd-array ) \ A new clone-like ;
M: A like drop dup \ A instance? [ >A ] unless ; inline
M: A new-sequence
drop dup N =
[ drop 16 <byte-array> 16 <byte-array> \ A boa ]
[ N bad-length ]
if ; inline
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
M: A byte-length drop 32 ; inline
SYNTAX: A{ \ } [ >A ] parse-literal ;
M: A pprint-delims drop \ A{ \ } ;
M: A >pprint-sequence ;
M: A pprint* pprint-object ;
INSTANCE: A sequence
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ [ underlying1>> ] bi@ A-rep ] dip call ]
[ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
\ A boa ; inline
: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
[ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
dip call ; inline
;FUNCTOR

1
basis/math/vectors/simd/intrinsics/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

28
basis/math/vectors/simd/intrinsics/intrinsics.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel alien alien.c-types cpu.architecture libc ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;
: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
: assert-positive ( x -- y ) ;
: alien-vector ( c-ptr n rep -- value )
! Inefficient version for when intrinsics are missing
[ swap <displaced-alien> ] dip rep-size memory>byte-array ;
: set-alien-vector ( value c-ptr n rep -- )
! Inefficient version for when intrinsics are missing
[ swap <displaced-alien> swap ] dip rep-size memcpy ;

255
basis/math/vectors/simd/simd-docs.factor Normal file
View File

@ -0,0 +1,255 @@
USING: help.markup help.syntax sequences math math.vectors
multiline kernel.private classes.tuple.private
math.vectors.simd.intrinsics cpu.architecture ;
IN: math.vectors.simd
ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
"Modern CPUs support a form of data-level parallelism, where arithmetic operations on fixed-size short vectors can be done on all components in parallel. This is known as single-instruction-multiple-data (SIMD)."
$nl
"SIMD support in the processor takes the form of instruction sets which operate on vector registers. By operating on multiple scalar values at the same time, code which operates on points, colors, and other vector data can be sped up."
$nl
"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized.)."
$nl
"The words in the " { $vocab-link "math.vectors" } " vocabulary, which can be used with any sequence of numbers, are special-cased by the compiler. If the compiler can prove that only SIMD vectors are used, it expands " { $link "math-vectors" } " into " { $link "math.vectors.simd.intrinsics" } ". While in the general case, SIMD intrinsics operate on heap-allocated SIMD vectors, that too can be optimized since in many cases the compiler unbox SIMD vectors, storing them directly in registers."
$nl
"Since the only difference between ordinary code and SIMD-accelerated code is that the latter uses special fixed-length SIMD sequences, the SIMD library is very easy to use. To ensure your code compiles to use vector instructions without boxing and unboxing overhead, follow the guidelines for " { $link "math.vectors.simd.efficiency" } "."
$nl
"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
$nl
"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
$nl
"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
$nl
"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
$nl
"The following vector types are defined:"
{ $subsection float-4 }
{ $subsection double-2 }
{ $subsection float-8 }
{ $subsection double-4 }
"For each vector type, several words are defined:"
{ $table
{ "Word" "Stack effect" "Description" }
{ { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
{ { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
{ { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
{ { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
}
"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
$nl
"Operations on " { $link float-4 } " instances:"
{ $subsection float-4-with }
{ $subsection float-4-boa }
{ $subsection POSTPONE: float-4{ }
"Operations on " { $link double-2 } " instances:"
{ $subsection double-2-with }
{ $subsection double-2-boa }
{ $subsection POSTPONE: double-2{ }
"Operations on " { $link float-8 } " instances:"
{ $subsection float-8-with }
{ $subsection float-8-boa }
{ $subsection POSTPONE: float-8{ }
"Operations on " { $link double-4 } " instances:"
{ $subsection double-4-with }
{ $subsection double-4-boa }
{ $subsection POSTPONE: double-4{ }
"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
{ $see-also "c-types-specs" } ;
ARTICLE: "math.vectors.simd.efficiency" "Writing efficient SIMD code"
"Since SIMD vectors are heap-allocated objects, it is important to write code in a style which is conducive to the compiler being able to inline generic dispatch and eliminate allocation."
$nl
"If the inputs to a " { $vocab-link "math.vectors" } " word are statically known to be SIMD vectors, the call is converted into an SIMD primitive, and the output is then also known to be an SIMD vector (or scalar, depending on the operation); this information propagates forward within a single word (together with any inlined words and macro expansions). Any intermediate values which are not stored into collections, or returned from the word, are furthermore unboxed."
$nl
"To check if optimizations are being performed, pass a quotation to the " { $snippet "optimizer-report." } " and " { $snippet "optimized." } " words in the " { $vocab-link "compiler.tree.debugger" } " vocabulary, and look for calls to " { $link "math.vectors.simd.intrinsics" } " as opposed to high-level " { $link "math-vectors" } "."
$nl
"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
{ $code
<" USING: compiler.tree.debugger math.vectors
math.vectors.simd ;
SYMBOLS: x y ;
[
double-4{ 1.5 2.0 3.7 0.4 } x set
double-4{ 1.5 2.0 3.7 0.4 } y set
x get y get v+
] optimizer-report."> }
"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
{ $code
<" USING: compiler.tree.debugger kernel.private
math.vectors math.vectors.simd ;
: interpolate ( v a b -- w )
{ float-4 float-4 float-4 } declare
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
\ interpolate optimizer-report. "> }
"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
$nl
"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
{ $code
<" USING: compiler.tree.debugger hints
math.vectors math.vectors.simd ;
: interpolate ( v a b -- w )
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
HINTS: interpolate float-4 float-4 float-4 ;
\ interpolate optimizer-report. "> }
"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
$nl
"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
$nl
"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
{ $code
<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
IN: simd-demo
STRUCT: actor
{ id int }
{ position float-4 }
{ velocity float-4 }
{ acceleration float-4 } ;
GENERIC: advance ( dt object -- )
: update-velocity ( dt actor -- )
[ acceleration>> n*v ] [ velocity>> v+ ] [ ] tri
(>>velocity) ; inline
: update-position ( dt actor -- )
[ velocity>> n*v ] [ position>> v+ ] [ ] tri
(>>position) ; inline
M: actor advance ( dt actor -- )
[ >float ] dip
[ update-velocity ] [ update-position ] 2bi ;
M\ actor advance optimized.">
}
"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
{ $code
<" USE: compiler.tree.debugger
M\ actor advance test-mr mr."> }
"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
"The words in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary are used to implement SIMD support. These words have three disadvantages compared to the higher-level " { $link "math-vectors" } " words:"
{ $list
"They operate on raw byte arrays, with a separate “representation” parameter passed in to determine the type of the operands and result."
"They are unsafe; passing values which are not byte arrays, or byte arrays with the wrong size, will dereference invalid memory and possibly crash Factor."
{ "They do not have software fallbacks; if the current CPU does not have SIMD support, a " { $link bad-simd-call } " error will be thrown." }
}
"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
$nl
"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
{ $subsection (simd-v+) }
{ $subsection (simd-v-) }
{ $subsection (simd-v/) }
{ $subsection (simd-vmin) }
{ $subsection (simd-vmax) }
{ $subsection (simd-vsqrt) }
{ $subsection (simd-sum) }
{ $subsection (simd-broadcast) }
{ $subsection (simd-gather-2) }
{ $subsection (simd-gather-4) }
"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
{ $subsection alien-vector }
{ $subsection set-alien-vector }
"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
{ $code
<" float-4
double-2
float-8
double-4"> }
"Passing SIMD data as function parameters is not yet supported." ;
ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
{ $subsection "math.vectors.simd.intro" }
{ $subsection "math.vectors.simd.types" }
{ $subsection "math.vectors.simd.support" }
{ $subsection "math.vectors.simd.efficiency" }
{ $subsection "math.vectors.simd.alien" }
{ $subsection "math.vectors.simd.intrinsics" } ;
! ! ! float-4
HELP: float-4
{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
HELP: float-4-with
{ $values { "x" float } { "simd-array" float-4 } }
{ $description "Creates a new vector with all four components equal to a scalar." } ;
HELP: float-4-boa
{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
{ $description "Creates a new vector from four scalar components." } ;
HELP: float-4{
{ $syntax "float-4{ a b c d }" }
{ $description "Literal syntax for a " { $link float-4 } "." } ;
! ! ! double-2
HELP: double-2
{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
HELP: double-2-with
{ $values { "x" float } { "simd-array" double-2 } }
{ $description "Creates a new vector with both components equal to a scalar." } ;
HELP: double-2-boa
{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
{ $description "Creates a new vector from two scalar components." } ;
HELP: double-2{
{ $syntax "double-2{ a b }" }
{ $description "Literal syntax for a " { $link double-2 } "." } ;
! ! ! float-8
HELP: float-8
{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
HELP: float-8-with
{ $values { "x" float } { "simd-array" float-8 } }
{ $description "Creates a new vector with all eight components equal to a scalar." } ;
HELP: float-8-boa
{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
{ $description "Creates a new vector from eight scalar components." } ;
HELP: float-8{
{ $syntax "float-8{ a b c d e f g h }" }
{ $description "Literal syntax for a " { $link float-8 } "." } ;
! ! ! double-4
HELP: double-4
{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
HELP: double-4-with
{ $values { "x" float } { "simd-array" double-4 } }
{ $description "Creates a new vector with all four components equal to a scalar." } ;
HELP: double-4-boa
{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
{ $description "Creates a new vector from four scalar components." } ;
HELP: double-4{
{ $syntax "double-4{ a b c d }" }
{ $description "Literal syntax for a " { $link double-4 } "." } ;
ABOUT: "math.vectors.simd"

361
basis/math/vectors/simd/simd-tests.factor Normal file
View File

@ -0,0 +1,361 @@
IN: math.vectors.simd.tests
USING: math math.vectors.simd math.vectors.simd.private
math.vectors math.functions math.private kernel.private compiler
sequences tools.test compiler.tree.debugger accessors kernel ;
[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
[ float-4{ 12 12 12 12 } ] [
12 [ float-4-with ] compile-call
] unit-test
[ float-4{ 1 2 3 4 } ] [
1 2 3 4 [ float-4-boa ] compile-call
] unit-test
[ float-4{ 11 22 33 44 } ] [
float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
[ { float-4 float-4 } declare v+ ] compile-call
] unit-test
[ float-4{ -9 -18 -27 -36 } ] [
float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
[ { float-4 float-4 } declare v- ] compile-call
] unit-test
[ float-4{ 10 40 90 160 } ] [
float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
[ { float-4 float-4 } declare v* ] compile-call
] unit-test
[ float-4{ 10 100 1000 10000 } ] [
float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
[ { float-4 float-4 } declare v/ ] compile-call
] unit-test
[ float-4{ -10 -20 -30 -40 } ] [
float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
[ { float-4 float-4 } declare vmin ] compile-call
] unit-test
[ float-4{ 10 20 30 40 } ] [
float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
[ { float-4 float-4 } declare vmax ] compile-call
] unit-test
[ 10.0 ] [
float-4{ 1 2 3 4 }
[ { float-4 } declare sum ] compile-call
] unit-test
[ 13.0 ] [
float-4{ 1 2 3 4 }
[ { float-4 } declare sum 3.0 + ] compile-call
] unit-test
[ 8.0 ] [
float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
[ { float-4 float-4 } declare v. ] compile-call
] unit-test
[ float-4{ 5 10 15 20 } ] [
5.0 float-4{ 1 2 3 4 }
[ { float float-4 } declare n*v ] compile-call
] unit-test
[ float-4{ 5 10 15 20 } ] [
float-4{ 1 2 3 4 } 5.0
[ { float float-4 } declare v*n ] compile-call
] unit-test
[ float-4{ 10 5 2 5 } ] [
10.0 float-4{ 1 2 5 2 }
[ { float float-4 } declare n/v ] compile-call
] unit-test
[ float-4{ 0.5 1 1.5 2 } ] [
float-4{ 1 2 3 4 } 2
[ { float float-4 } declare v/n ] compile-call
] unit-test
[ float-4{ 1 0 0 0 } ] [
float-4{ 10 0 0 0 }
[ { float-4 } declare normalize ] compile-call
] unit-test
[ 30.0 ] [
float-4{ 1 2 3 4 }
[ { float-4 } declare norm-sq ] compile-call
] unit-test
[ t ] [
float-4{ 1 0 0 0 }
float-4{ 0 1 0 0 }
[ { float-4 float-4 } declare distance ] compile-call
2 sqrt 1.0e-6 ~
] unit-test
[ double-2{ 12 12 } ] [
12 [ double-2-with ] compile-call
] unit-test
[ double-2{ 1 2 } ] [
1 2 [ double-2-boa ] compile-call
] unit-test
[ double-2{ 11 22 } ] [
double-2{ 1 2 } double-2{ 10 20 }
[ { double-2 double-2 } declare v+ ] compile-call
] unit-test
[ double-2{ -9 -18 } ] [
double-2{ 1 2 } double-2{ 10 20 }
[ { double-2 double-2 } declare v- ] compile-call
] unit-test
[ double-2{ 10 40 } ] [
double-2{ 1 2 } double-2{ 10 20 }
[ { double-2 double-2 } declare v* ] compile-call
] unit-test
[ double-2{ 10 100 } ] [
double-2{ 100 2000 } double-2{ 10 20 }
[ { double-2 double-2 } declare v/ ] compile-call
] unit-test
[ double-2{ -10 -20 } ] [
double-2{ -10 20 } double-2{ 10 -20 }
[ { double-2 double-2 } declare vmin ] compile-call
] unit-test
[ double-2{ 10 20 } ] [
double-2{ -10 20 } double-2{ 10 -20 }
[ { double-2 double-2 } declare vmax ] compile-call
] unit-test
[ 3.0 ] [
double-2{ 1 2 }
[ { double-2 } declare sum ] compile-call
] unit-test
[ 7.0 ] [
double-2{ 1 2 }
[ { double-2 } declare sum 4.0 + ] compile-call
] unit-test
[ 16.0 ] [
double-2{ 1 2 } double-2{ 2 7 }
[ { double-2 double-2 } declare v. ] compile-call
] unit-test
[ double-2{ 5 10 } ] [
5.0 double-2{ 1 2 }
[ { float double-2 } declare n*v ] compile-call
] unit-test
[ double-2{ 5 10 } ] [
double-2{ 1 2 } 5.0
[ { float double-2 } declare v*n ] compile-call
] unit-test
[ double-2{ 10 5 } ] [
10.0 double-2{ 1 2 }
[ { float double-2 } declare n/v ] compile-call
] unit-test
[ double-2{ 0.5 1 } ] [
double-2{ 1 2 } 2
[ { float double-2 } declare v/n ] compile-call
] unit-test
[ double-2{ 0 0 } ] [ double-2 new ] unit-test
[ double-2{ 1 0 } ] [
double-2{ 10 0 }
[ { double-2 } declare normalize ] compile-call
] unit-test
[ 5.0 ] [
double-2{ 1 2 }
[ { double-2 } declare norm-sq ] compile-call
] unit-test
[ t ] [
double-2{ 1 0 }
double-2{ 0 1 }
[ { double-2 double-2 } declare distance ] compile-call
2 sqrt 1.0e-6 ~
] unit-test
[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
[ double-4{ 1 2 3 4 } ] [
1 2 3 4 double-4-boa
] unit-test
[ double-4{ 1 1 1 1 } ] [
1 double-4-with
] unit-test
[ double-4{ 0 1 2 3 } ] [
1 double-4-with [ * ] map-index
] unit-test
[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
[ double-4{ 12 12 12 12 } ] [
12 [ double-4-with ] compile-call
] unit-test
[ double-4{ 1 2 3 4 } ] [
1 2 3 4 [ double-4-boa ] compile-call
] unit-test
[ double-4{ 11 22 33 44 } ] [
double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
[ { double-4 double-4 } declare v+ ] compile-call
] unit-test
[ double-4{ -9 -18 -27 -36 } ] [
double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
[ { double-4 double-4 } declare v- ] compile-call
] unit-test
[ double-4{ 10 40 90 160 } ] [
double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
[ { double-4 double-4 } declare v* ] compile-call
] unit-test
[ double-4{ 10 100 1000 10000 } ] [
double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
[ { double-4 double-4 } declare v/ ] compile-call
] unit-test
[ double-4{ -10 -20 -30 -40 } ] [
double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
[ { double-4 double-4 } declare vmin ] compile-call
] unit-test
[ double-4{ 10 20 30 40 } ] [
double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
[ { double-4 double-4 } declare vmax ] compile-call
] unit-test
[ 10.0 ] [
double-4{ 1 2 3 4 }
[ { double-4 } declare sum ] compile-call
] unit-test
[ 13.0 ] [
double-4{ 1 2 3 4 }
[ { double-4 } declare sum 3.0 + ] compile-call
] unit-test
[ 8.0 ] [
double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
[ { double-4 double-4 } declare v. ] compile-call
] unit-test
[ double-4{ 5 10 15 20 } ] [
5.0 double-4{ 1 2 3 4 }
[ { float double-4 } declare n*v ] compile-call
] unit-test
[ double-4{ 5 10 15 20 } ] [
double-4{ 1 2 3 4 } 5.0
[ { float double-4 } declare v*n ] compile-call
] unit-test
[ double-4{ 10 5 2 5 } ] [
10.0 double-4{ 1 2 5 2 }
[ { float double-4 } declare n/v ] compile-call
] unit-test
[ double-4{ 0.5 1 1.5 2 } ] [
double-4{ 1 2 3 4 } 2
[ { float double-4 } declare v/n ] compile-call
] unit-test
[ double-4{ 1 0 0 0 } ] [
double-4{ 10 0 0 0 }
[ { double-4 } declare normalize ] compile-call
] unit-test
[ 30.0 ] [
double-4{ 1 2 3 4 }
[ { double-4 } declare norm-sq ] compile-call
] unit-test
[ t ] [
double-4{ 1 0 0 0 }
double-4{ 0 1 0 0 }
[ { double-4 double-4 } declare distance ] compile-call
2 sqrt 1.0e-6 ~
] unit-test
[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
[ float-8{ 3 6 9 12 15 18 21 24 } ] [
float-8{ 1 2 3 4 5 6 7 8 }
float-8{ 2 4 6 8 10 12 14 16 }
[ { float-8 float-8 } declare v+ ] compile-call
] unit-test
[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
float-8{ 1 2 3 4 5 6 7 8 }
float-8{ 2 4 6 8 10 12 14 16 }
[ { float-8 float-8 } declare v- ] compile-call
] unit-test
[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
-0.5
float-8{ 2 4 6 8 10 12 14 16 }
[ { float float-8 } declare n*v ] compile-call
] unit-test
[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
float-8{ 2 4 6 8 10 12 14 16 }
-0.5
[ { float-8 float } declare v*n ] compile-call
] unit-test
[ float-8{ 256 128 64 32 16 8 4 2 } ] [
256.0
float-8{ 1 2 4 8 16 32 64 128 }
[ { float float-8 } declare n/v ] compile-call
] unit-test
[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
float-8{ 2 4 6 8 10 12 14 16 }
-2.0
[ { float-8 float } declare v/n ] compile-call
] unit-test
! Test puns
[ double-2{ 4 1024 } ] [
float-4{ 0 1 0 2 }
[ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
] unit-test
[ 33.0 ] [
double-2{ 1 2 } double-2{ 10 20 }
[ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
] unit-test

183
basis/math/vectors/simd/simd.factor Normal file
View File

@ -0,0 +1,183 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types byte-arrays cpu.architecture
kernel math math.functions math.vectors
math.vectors.simd.functor math.vectors.simd.intrinsics
math.vectors.specialization parser prettyprint.custom sequences
sequences.private locals assocs words fry ;
IN: math.vectors.simd
<<
DEFER: float-4
DEFER: double-2
DEFER: float-8
DEFER: double-4
"double" define-simd-128
"float" define-simd-128
"double" define-simd-256
"float" define-simd-256
>>
: float-4-with ( x -- simd-array )
[ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
: float-4-boa ( a b c d -- simd-array )
\ float-4 new 4sequence ;
: double-2-with ( x -- simd-array )
[ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
: double-2-boa ( a b -- simd-array )
\ double-2 new 2sequence ;
! More efficient expansions for the above, used when SIMD is
! actually available.
<<
\ float-4-with [
drop
\ (simd-broadcast) "intrinsic" word-prop [
[ >float float-4-rep (simd-broadcast) \ float-4 boa ]
] [ \ float-4-with def>> ] if
] "custom-inlining" set-word-prop
\ float-4-boa [
drop
\ (simd-gather-4) "intrinsic" word-prop [
[| a b c d |
a >float b >float c >float d >float
float-4-rep (simd-gather-4) \ float-4 boa
]
] [ \ float-4-boa def>> ] if
] "custom-inlining" set-word-prop
\ double-2-with [
drop
\ (simd-broadcast) "intrinsic" word-prop [
[ >float double-2-rep (simd-broadcast) \ double-2 boa ]
] [ \ double-2-with def>> ] if
] "custom-inlining" set-word-prop
\ double-2-boa [
drop
\ (simd-gather-4) "intrinsic" word-prop [
[ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
] [ \ double-2-boa def>> ] if
] "custom-inlining" set-word-prop
>>
: float-8-with ( x -- simd-array )
[ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
\ float-8 boa ; inline
:: float-8-boa ( a b c d e f g h -- simd-array )
a b c d float-4-boa
e f g h float-4-boa
[ underlying>> ] bi@
\ float-8 boa ; inline
: double-4-with ( x -- simd-array )
[ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
\ double-4 boa ; inline
:: double-4-boa ( a b c d -- simd-array )
a b double-2-boa
c d double-2-boa
[ underlying>> ] bi@
\ double-4 boa ; inline
<<
<PRIVATE
! Filter out operations that are not available, eg horizontal adds
! on SSE2. Fallback code in math.vectors is used in that case.
: supported-simd-ops ( assoc -- assoc' )
{
{ v+ (simd-v+) }
{ v- (simd-v-) }
{ v* (simd-v*) }
{ v/ (simd-v/) }
{ vmin (simd-vmin) }
{ vmax (simd-vmax) }
{ sum (simd-sum) }
} [ nip "intrinsic" word-prop ] assoc-filter
'[ drop _ key? ] assoc-filter ;
! Some SIMD operations are defined in terms of others.
:: high-level-ops ( ctor -- assoc )
{
{ vneg [ [ dup v- ] keep v- ] }
{ v. [ v* sum ] }
{ n+v [ [ ctor execute ] dip v+ ] }
{ v+n [ ctor execute v+ ] }
{ n-v [ [ ctor execute ] dip v- ] }
{ v-n [ ctor execute v- ] }
{ n*v [ [ ctor execute ] dip v* ] }
{ v*n [ ctor execute v* ] }
{ n/v [ [ ctor execute ] dip v/ ] }
{ v/n [ ctor execute v/ ] }
{ norm-sq [ dup v. assert-positive ] }
{ norm [ norm-sq sqrt ] }
{ normalize [ dup norm v/n ] }
{ distance [ v- norm ] }
} ;
:: simd-vector-words ( class ctor elt-type assoc -- )
class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
specialize-vector-words ;
PRIVATE>
\ float-4 \ float-4-with float H{
{ v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
{ v- [ [ (simd-v-) ] float-4-vv->v-op ] }
{ v* [ [ (simd-v*) ] float-4-vv->v-op ] }
{ v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
{ vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
{ vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
{ sum [ [ (simd-sum) ] float-4-v->n-op ] }
} simd-vector-words
\ double-2 \ double-2-with float H{
{ v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
{ v- [ [ (simd-v-) ] double-2-vv->v-op ] }
{ v* [ [ (simd-v*) ] double-2-vv->v-op ] }
{ v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
{ vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
{ vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
{ sum [ [ (simd-sum) ] double-2-v->n-op ] }
} simd-vector-words
\ float-8 \ float-8-with float H{
{ v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
{ v- [ [ (simd-v-) ] float-8-vv->v-op ] }
{ v* [ [ (simd-v*) ] float-8-vv->v-op ] }
{ v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
{ vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
{ vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
{ sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
} simd-vector-words
\ double-4 \ double-4-with float H{
{ v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
{ v- [ [ (simd-v-) ] double-4-vv->v-op ] }
{ v* [ [ (simd-v*) ] double-4-vv->v-op ] }
{ v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
{ vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
{ vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
{ sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
} simd-vector-words
>>
USE: vocabs.loader
"math.vectors.simd.alien" require

35
basis/math/vectors/specialization/specialization.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel make sequences effects kernel.private accessors
combinators math math.intervals math.vectors namespaces assocs fry
splitting classes.algebra generalizations
splitting classes.algebra generalizations locals
compiler.tree.propagation.info ;
IN: math.vectors.specialization
@ -67,14 +67,19 @@ H{
{ vmin { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
{ sum { +vector+ -> +scalar+ } }
}
SYMBOL: specializations
PREDICATE: vector-word < word vector-words key? ;
specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
: specializations ( word -- assoc )
dup "specializations" word-prop
[ ] [ V{ } clone [ "specializations" set-word-prop ] keep ] ?if ;
M: vector-word subwords specializations values ;
: add-specialization ( new-word signature word -- )
specializations get at set-at ;
specializations set-at ;
: word-schema ( word -- schema ) vector-words at ;
@ -82,23 +87,27 @@ specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
: outputs ( schema -- seq ) { -> } split second ;
: specialize-vector-word ( word array-type elt-type -- word' )
: loop-vector-op ( word array-type elt-type -- word' )
pick word-schema
[ inputs (specialize-vector-word) ]
[ outputs record-output-signature ] 3bi ;
: input-signature ( word -- signature ) def>> first ;
:: specialize-vector-word ( word array-type elt-type simd -- word/quot' )
word simd key? [ word simd at ] [ word array-type elt-type loop-vector-op ] if ;
: specialize-vector-words ( array-type elt-type -- )
[ vector-words keys ] 2dip
'[
[ _ _ specialize-vector-word ] keep
[ dup input-signature ] dip
add-specialization
:: input-signature ( word array-type elt-type -- signature )
array-type elt-type word word-schema inputs signature-for-schema ;
:: specialize-vector-words ( array-type elt-type simd -- )
vector-words keys [
[ array-type elt-type simd specialize-vector-word ]
[ array-type elt-type input-signature ]
[ ]
tri add-specialization
] each ;
: find-specialization ( classes word -- word/f )
specializations get at
specializations
[ first [ class<= ] 2all? ] with find
swap [ second ] when ;

6
basis/math/vectors/vectors-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax math sequences ;
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
"Any Factor sequence can be used to represent a mathematical vector."
"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used."
$nl
"Acting on vectors by a scalar:"
{ $subsection vneg }
@ -10,6 +10,10 @@ $nl
{ $subsection n*v }
{ $subsection v/n }
{ $subsection n/v }
{ $subsection v+n }
{ $subsection n+v }
{ $subsection v-n }
{ $subsection n-v }
"Combining two vectors to form another vector with " { $link 2map } ":"
{ $subsection v+ }
{ $subsection v- }

33
basis/prettyprint/backend/backend.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays byte-vectors continuations
generic hashtables assocs kernel math namespaces make sequences
strings sbufs vectors words prettyprint.config prettyprint.custom
prettyprint.sections quotations io io.pathnames io.styles math.parser
effects classes.tuple math.order classes.tuple.private classes
combinators colors ;
USING: accessors arrays assocs byte-arrays byte-vectors classes
classes.tuple classes.tuple.private colors colors.constants
combinators continuations effects generic hashtables io
io.pathnames io.styles kernel make math math.order math.parser
namespaces prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.stylesheet quotations sbufs
sequences strings vectors words words.symbol ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
@ -20,17 +21,6 @@ M: effect pprint* effect>string "(" ")" surround text ;
?effect-height 0 < [ end-group ] when ;
! Atoms
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
[
[ presented set ]
[
[ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
[ bold font-style set ] when
] bi
] bind
] keep ;
: word-name* ( word -- str )
name>> "( no name )" or ;
@ -59,6 +49,9 @@ M: real pprint* number>string text ;
M: f pprint* drop \ f pprint-word ;
: pprint-effect ( effect -- )
[ effect>string ] [ effect-style ] bi styled-text ;
! Strings
: ch>ascii-escape ( ch -- str )
H{
@ -82,12 +75,6 @@ M: f pprint* drop \ f pprint-word ;
] when
] when ;
: string-style ( obj -- hash )
[
presented set
T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
] H{ } make-assoc ;
: unparse-string ( str prefix suffix -- str )
[ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;

Some files were not shown because too many files have changed in this diff Show More