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

basis/alien/inline/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

basis/alien/inline/compiler/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

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 ;

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
+
+<PRIVATE
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: compiler-args
+SYMBOL: c-strings
+
+: (C-LIBRARY:) ( -- )
+    scan c-library set
+    V{ } clone c-strings set
+    V{ } clone compiler-args set ;
+
+: (C-LINK:) ( -- )
+    "-l" scan append compiler-args get push ;
+
+: (C-FRAMEWORK:) ( -- )
+    "-framework" scan compiler-args get '[ _ push ] bi@ ;
+
+: return-library-function-params ( -- return library function params )
+    scan c-library get scan ")" parse-tokens
+    [ "(" subseq? not ] filter [
+        [ dup CHAR: - = [ drop CHAR: space ] when ] map
+    ] 3dip ;
+
+: factor-function ( return library functions params -- )
+    [ dup "const " head? [ 6 tail ] when ] 3dip
+    make-function define-declared ;
+
+: (C-FUNCTION:) ( return library function params -- str )
+    [ nip ] dip
+    " " join "(" prepend ")" append 3array " " join
+    library-is-c++ get [ "extern \"C\" " prepend ] when ;
+
+: library-path ( -- str )
+    "lib" c-library get library-suffix
+    3array concat temp-file ;
+
+: compile-library? ( -- ? )
+    library-path dup exists? [
+        current-vocab vocab-source-path
+        [ file-info modified>> ] 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) ;

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: <string>
+
+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 >>

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

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 ;

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 <array> 3 100000 pick set-nth

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