diff --git a/basis/alien/inline/authors.txt b/basis/alien/inline/authors.txt new file mode 100644 index 0000000000..845910d5a0 --- /dev/null +++ b/basis/alien/inline/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes diff --git a/basis/alien/inline/compiler/authors.txt b/basis/alien/inline/compiler/authors.txt new file mode 100644 index 0000000000..845910d5a0 --- /dev/null +++ b/basis/alien/inline/compiler/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor new file mode 100644 index 0000000000..0ac702478b --- /dev/null +++ b/basis/alien/inline/compiler/compiler.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators fry generalizations +io.encodings.ascii io.files io.files.temp io.launcher kernel +locals sequences system ; +IN: alien.inline.compiler + +SYMBOL: C +SYMBOL: C++ + +: library-suffix ( -- str ) + os { + { [ dup macosx? ] [ drop ".dylib" ] } + { [ dup unix? ] [ drop ".so" ] } + { [ dup windows? ] [ drop ".dll" ] } + } cond ; + +: src-suffix ( lang -- str ) + { + { C [ ".c" ] } + { C++ [ ".cpp" ] } + } case ; + +:: compile-to-object ( lang contents name -- ) + name ".o" append temp-file + contents name lang src-suffix append temp-file + [ ascii set-file-contents ] keep 2array + { "gcc" "-fPIC" "-c" "-o" } prepend try-process ; + +: link-object ( args name -- ) + [ "lib" prepend library-suffix append ] [ ".o" append ] bi + [ temp-file ] bi@ 2array + os { + { [ dup linux? ] + [ drop { "gcc" "-shared" "-o" } ] } + { [ dup macosx? ] + [ drop { "gcc" "-g" "-prebind" "-dynamiclib" "-o" } ] } + [ name>> "unimplemented for: " prepend throw ] + } cond prepend prepend try-process ; + +:: compile-to-library ( lang args contents name -- ) + lang contents name compile-to-object + args name link-object ; diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor new file mode 100644 index 0000000000..5e235fe74e --- /dev/null +++ b/basis/alien/inline/inline.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.inline.compiler alien.libraries +alien.parser arrays fry generalizations io.files io.files.info +io.files.temp kernel lexer math.order multiline namespaces +sequences system vocabs.loader vocabs.parser words ; +IN: alien.inline + +> ] bi@ <=> +lt+ = + ] [ drop t ] if ; + +: compile-library ( -- ) + library-is-c++ get [ C++ ] [ C ] if + compiler-args get + c-strings get "\n" join + c-library get compile-to-library ; + +: (;C-LIBRARY) ( -- ) + compile-library? [ compile-library ] when + c-library get library-path "cdecl" add-library ; +PRIVATE> + +SYNTAX: C-LIBRARY: (C-LIBRARY:) ; + +SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; + +SYNTAX: C-LINK: (C-LINK:) ; + +SYNTAX: C-FRAMEWORK: (C-FRAMEWORK:) ; + +SYNTAX: C-LINK/FRAMEWORK: + os macosx? [ (C-FRAMEWORK:) ] [ (C-LINK:) ] if ; + +SYNTAX: C-INCLUDE: + "#include " scan append c-strings get push ; + +SYNTAX: C-FUNCTION: + return-library-function-params + [ factor-function ] + 4 nkeep (C-FUNCTION:) + " {\n" append parse-here append "\n}\n" append + c-strings get push ; + +SYNTAX: ;C-LIBRARY (;C-LIBRARY) ; diff --git a/basis/alien/inline/tests/tests.factor b/basis/alien/inline/tests/tests.factor new file mode 100644 index 0000000000..aea41ea8b8 --- /dev/null +++ b/basis/alien/inline/tests/tests.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.inline alien.inline.private io.files io.directories kernel ; +IN: alien.inline.tests + +C-LIBRARY: const + +C-FUNCTION: const-int add ( int a, int b ) + return a + b; +; + +;C-LIBRARY + +{ 2 1 } [ add ] must-infer-as +[ 5 ] [ 2 3 add ] unit-test + +<< library-path dup exists? [ delete-file ] [ drop ] if >> + + +C-LIBRARY: cpplib + +COMPILE-AS-C++ + +C-INCLUDE: + +C-FUNCTION: const-char* hello ( ) + std::string s("hello world"); + return s.c_str(); +; + +;C-LIBRARY + +{ 0 1 } [ hello ] must-infer-as +[ "hello world" ] [ hello ] unit-test + +<< library-path dup exists? [ delete-file ] [ drop ] if >> + + +C-LIBRARY: compile-error + +C-FUNCTION: char* breakme ( ) + return not a string; +; + +<< [ (;C-LIBRARY) ] must-fail >> + +<< library-path dup exists? [ delete-file ] [ drop ] if >> diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index ee601f2337..97ebc7cc3e 100644 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,7 +1,8 @@ -USING: arrays sequences tools.test compiler.cfg.checker -compiler.cfg.debugger compiler.cfg.def-use sets kernel -kernel.private fry slots.private vectors sequences.private -math sbufs math.private strings ; +USING: accessors arrays compiler.cfg.checker +compiler.cfg.debugger compiler.cfg.def-use +compiler.cfg.instructions fry kernel kernel.private math +math.private sbufs sequences sequences.private sets +slots.private strings tools.test vectors ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests @@ -33,3 +34,11 @@ IN: compiler.cfg.optimizer.tests } [ [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test ] each + +[ t ] +[ + [ + HEX: 7fff fixnum-bitand 13 fixnum-shift-fast + 112 23 fixnum-shift-fast fixnum+fast + ] test-mr first instructions>> [ ##add? ] any? +] unit-test diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor old mode 100644 new mode 100755 index bdb906da79..bbfeb3f8bf --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.short-circuit -compiler.cfg.hats compiler.cfg.instructions +arrays compiler.cfg.hats compiler.cfg.instructions compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.simplify fry kernel layouts math @@ -113,38 +113,60 @@ M: ##compare-imm rewrite ] when ] when ; +: constant-fold ( insn -- insn' ) + dup dst>> vreg>expr dup constant-expr? [ + [ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn + dup number-values + ] [ + drop + ] if ; + +: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn ) + [ cell-bits bits ] dip over small-enough? [ + new-insn dup number-values nip + ] [ + 2drop 2drop + ] if constant-fold ; inline + +: new-imm-insn ( insn dst src n op -- n' op' ) + 2dup [ sgn ] dip 2array + { + { { -1 ##add-imm } [ drop neg \ ##sub-imm (new-imm-insn) ] } + { { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] } + [ drop (new-imm-insn) ] + } case ; inline + : combine-imm? ( insn op -- ? ) [ src1>> vreg>expr op>> ] dip = ; +: (combine-imm) ( insn quot op -- insn ) + [ + { + [ ] + [ dst>> ] + [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] + [ src2>> ] + } cleave + ] [ call ] [ ] tri* new-imm-insn ; inline + :: combine-imm ( insn quot op -- insn ) - insn - [ dst>> ] - [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] - [ src2>> ] tri - - quot call cell-bits bits - - dup small-enough? [ - op new-insn dup number-values + insn op combine-imm? [ + insn quot op (combine-imm) ] [ - 3drop insn + insn ] if ; inline M: ##add-imm rewrite { - { [ dup \ ##add-imm combine-imm? ] - [ [ + ] \ ##add-imm combine-imm ] } - { [ dup \ ##sub-imm combine-imm? ] - [ [ - ] \ ##sub-imm combine-imm ] } + { [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] } + { [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] } [ ] } cond ; M: ##sub-imm rewrite { - { [ dup \ ##add-imm combine-imm? ] - [ [ - ] \ ##add-imm combine-imm ] } - { [ dup \ ##sub-imm combine-imm? ] - [ [ + ] \ ##sub-imm combine-imm ] } + { [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] } + { [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] } [ ] } cond ; @@ -153,26 +175,27 @@ M: ##mul-imm rewrite [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn dup number-values ] [ - drop dup \ ##mul-imm combine-imm? - [ [ * ] \ ##mul-imm combine-imm ] when + drop [ * ] \ ##mul-imm combine-imm ] if ; -M: ##and-imm rewrite - dup \ ##and-imm combine-imm? - [ [ bitand ] \ ##and-imm combine-imm ] when ; +M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ; -M: ##or-imm rewrite - dup \ ##or-imm combine-imm? - [ [ bitor ] \ ##or-imm combine-imm ] when ; +M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ; -M: ##xor-imm rewrite - dup \ ##xor-imm combine-imm? - [ [ bitxor ] \ ##xor-imm combine-imm ] when ; +M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ; + +: rewrite-add? ( insn -- ? ) + src2>> { + [ vreg>expr constant-expr? ] + [ vreg>constant small-enough? ] + } 1&& ; M: ##add rewrite - dup src2>> vreg>expr constant-expr? [ + dup rewrite-add? [ [ dst>> ] [ src1>> ] [ src2>> vreg>constant ] tri \ ##add-imm new-insn dup number-values ] when ; + +M: ##sub rewrite constant-fold ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index d0cfc127e3..df7f1c8513 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -238,6 +238,13 @@ IN: compiler.tests.intrinsics [ t ] [ f [ f eq? ] compile-call ] unit-test +cell 8 = [ + [ HEX: 40400000 ] [ + HEX: 4200 [ HEX: 7fff fixnum-bitand 13 fixnum-shift-fast 112 23 fixnum-shift-fast fixnum+fast ] + compile-call + ] unit-test +] when + ! regression [ 3 ] [ 100001 f 3 100000 pick set-nth diff --git a/extra/half-floats/half-floats-tests.factor b/extra/half-floats/half-floats-tests.factor index 001cc6200b..3eff29635c 100644 --- a/extra/half-floats/half-floats-tests.factor +++ b/extra/half-floats/half-floats-tests.factor @@ -25,6 +25,7 @@ IN: half-floats.tests [ -1.5 ] [ HEX: be00 bits>half ] unit-test [ 1/0. ] [ HEX: 7c00 bits>half ] unit-test [ -1/0. ] [ HEX: fc00 bits>half ] unit-test +[ 3.0 ] [ HEX: 4200 bits>half ] unit-test [ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test C-STRUCT: halves