diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor new file mode 100644 index 0000000000..39d9a64c41 --- /dev/null +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit kernel sequences math +compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.utilities ; +IN: compiler.cfg.block-joining + +! Joining blocks that are not calls and are connected by a single CFG edge. +! Predecessors must be recomputed after this. Also this pass does not +! update ##phi nodes and should therefore only run before stack analysis. + +: kill-vreg-block? ( bb -- ? ) + instructions>> { + [ length 2 >= ] + [ penultimate kill-vreg-insn? ] + } 1&& ; + +: predecessor ( bb -- pred ) + predecessors>> first ; inline + +: join-block? ( bb -- ? ) + { + [ kill-vreg-block? not ] + [ predecessors>> length 1 = ] + [ predecessor kill-vreg-block? not ] + [ predecessor successors>> length 1 = ] + [ [ predecessor ] keep back-edge? not ] + } 1&& ; + +: join-instructions ( bb pred -- ) + [ instructions>> ] bi@ dup pop* push-all ; + +: update-successors ( bb pred -- ) + [ successors>> ] dip (>>successors) ; + +: join-block ( bb pred -- ) + [ join-instructions ] [ update-successors ] 2bi ; + +: join-blocks ( cfg -- cfg' ) + dup post-order [ + dup join-block? + [ dup predecessor join-block ] [ drop ] if + ] each + cfg-changed ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 910cb1992b..2f2668df8b 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -223,3 +223,25 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; +! Instructions that poison the stack state +UNION: poison-insn + ##jump + ##return + ##callback-return + ##fixnum-mul-tail + ##fixnum-add-tail + ##fixnum-sub-tail ; + +! Instructions that kill all live vregs +UNION: kill-vreg-insn + poison-insn + ##stack-frame + ##call + ##prologue + ##epilogue + ##fixnum-mul + ##fixnum-add + ##fixnum-sub + ##alien-invoke + ##alien-indirect + ##alien-callback ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index bf7e8bc042..d2fa661136 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -122,10 +122,10 @@ M: ##copy-float compute-live-intervals* dup ranges>> [ first from>> ] [ last to>> ] bi [ >>start ] [ >>end ] bi* drop ; -: check-start/end ( live-interval -- ) - [ [ start>> ] [ uses>> first ] bi assert= ] - [ [ end>> ] [ uses>> last ] bi assert= ] - bi ; +ERROR: bad-live-interval live-interval ; + +: check-start ( live-interval -- ) + dup start>> -1 = [ bad-live-interval ] [ drop ] if ; : finish-live-intervals ( live-intervals -- ) ! Since live intervals are computed in a backward order, we have @@ -135,7 +135,7 @@ M: ##copy-float compute-live-intervals* [ ranges>> reverse-here ] [ uses>> reverse-here ] [ compute-start/end ] - [ check-start/end ] + [ check-start ] } cleave ] each ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index e16fb734e1..1af0fcbc53 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -6,6 +6,7 @@ compiler.cfg.predecessors compiler.cfg.useless-conditionals compiler.cfg.stack-analysis compiler.cfg.branch-splitting +compiler.cfg.block-joining compiler.cfg.alias-analysis compiler.cfg.value-numbering compiler.cfg.dce @@ -31,6 +32,8 @@ SYMBOL: check-optimizer? delete-useless-conditionals compute-predecessors split-branches + join-blocks + compute-predecessors stack-analysis compute-liveness alias-analysis diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index 5fa2e1b042..8be9c15b04 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators.short-circuit kernel math namespaces sequences fry combinators +compiler.utilities compiler.cfg compiler.cfg.rpo compiler.cfg.hats @@ -19,8 +20,6 @@ IN: compiler.cfg.tco [ second ##return? ] } 1&& ; -: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; - : tail-call? ( bb -- ? ) { [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ] diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index aec61608f1..f5ea64bc0a 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -14,7 +14,8 @@ compiler.tree.propagation.nodes compiler.tree.propagation.slots compiler.tree.propagation.simple compiler.tree.propagation.constraints -compiler.tree.propagation.call-effect ; +compiler.tree.propagation.call-effect +compiler.tree.propagation.transforms ; IN: compiler.tree.propagation.known-words \ fixnum @@ -227,39 +228,6 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each -: rem-custom-inlining ( #call -- quot/f ) - second value-info literal>> dup integer? - [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; - -{ - mod-integer-integer - mod-integer-fixnum - mod-fixnum-integer - fixnum-mod -} [ - [ - in-d>> dup first value-info interval>> [0,inf] interval-subset? - [ rem-custom-inlining ] [ drop f ] if - ] "custom-inlining" set-word-prop -] each - -\ rem [ - in-d>> rem-custom-inlining -] "custom-inlining" set-word-prop - -{ - bitand-integer-integer - bitand-integer-fixnum - bitand-fixnum-integer -} [ - [ - in-d>> second value-info >literal< [ - 0 most-positive-fixnum between? - [ [ >fixnum ] bi@ fixnum-bitand ] f ? - ] when - ] "custom-inlining" set-word-prop -] each - { numerator denominator } [ [ drop integer ] "outputs" set-word-prop ] each @@ -314,15 +282,6 @@ generic-comparison-ops [ "outputs" set-word-prop ] each -! Generate more efficient code for common idiom -\ clone [ - in-d>> first value-info literal>> { - { V{ } [ [ drop { } 0 vector boa ] ] } - { H{ } [ [ drop 0 ] ] } - [ drop f ] - } case -] "custom-inlining" set-word-prop - \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if @@ -346,29 +305,3 @@ generic-comparison-ops [ bi ] [ 2drop object-info ] if ] "outputs" set-word-prop - -\ instance? [ - in-d>> second value-info literal>> dup class? - [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if -] "custom-inlining" set-word-prop - -\ equal? [ - ! If first input has a known type and second input is an - ! object, we convert this to [ swap equal? ]. - in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method - [ swap equal? ] f ? - ] [ drop f ] if -] "custom-inlining" set-word-prop - -: inline-new ( class -- quot/f ) - dup tuple-class? [ - dup inlined-dependency depends-on - [ all-slots [ initial>> literalize ] map ] - [ tuple-layout '[ _ ] ] - bi append [ drop ] prepend >quotation - ] [ drop f ] if ; - -\ new [ - in-d>> first value-info literal>> inline-new -] "custom-inlining" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 108afad296..0a5dbab883 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -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 ; +math.intervals quotations effects ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -717,3 +717,26 @@ M: number whatever drop foo ; : that-thing ( -- class ) foo ; [ f ] [ [ that-thing new ] { new } inlined? ] unit-test + +GENERIC: whatever2 ( x -- y ) +M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; +M: f whatever2 ; + +[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test +[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test + +[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test + +[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test + +[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test +[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test + +[ f ] [ [ instance? ] { instance? } inlined? ] unit-test +[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test +[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test + +[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/authors.txt b/basis/compiler/tree/propagation/transforms/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/tree/propagation/transforms/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor new file mode 100644 index 0000000000..60f1db5093 --- /dev/null +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -0,0 +1,191 @@ +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences words fry generic accessors classes.tuple +classes classes.algebra definitions stack-checker.state quotations +classes.tuple.private math math.partial-dispatch math.private +math.intervals layouts math.order vectors hashtables +combinators effects generalizations assocs sets +combinators.short-circuit sequences.private locals +stack-checker +compiler.tree.propagation.info ; +IN: compiler.tree.propagation.transforms + +\ equal? [ + ! If first input has a known type and second input is an + ! object, we convert this to [ swap equal? ]. + in-d>> first2 value-info class>> object class= [ + value-info class>> \ equal? specific-method + [ swap equal? ] f ? + ] [ drop f ] if +] "custom-inlining" set-word-prop + +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + +{ + mod-integer-integer + mod-integer-fixnum + mod-fixnum-integer + fixnum-mod +} [ + [ + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if + ] "custom-inlining" set-word-prop +] each + +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + +{ + bitand-integer-integer + bitand-integer-fixnum + bitand-fixnum-integer +} [ + [ + in-d>> second value-info >literal< [ + 0 most-positive-fixnum between? + [ [ >fixnum ] bi@ fixnum-bitand ] f ? + ] when + ] "custom-inlining" set-word-prop +] each + +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop 0 ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + +ERROR: bad-partial-eval quot word ; + +: check-effect ( quot word -- ) + 2dup [ infer ] [ stack-effect ] bi* effect<= + [ 2drop ] [ bad-partial-eval ] if ; + +:: define-partial-eval ( word quot n -- ) + word [ + in-d>> n tail* + [ value-info ] map + dup [ literal?>> ] all? [ + [ literal>> ] map + n firstn + quot call dup [ + [ n ndrop ] prepose + dup word check-effect + ] when + ] [ drop f ] if + ] "custom-inlining" set-word-prop ; + +: inline-new ( class -- quot/f ) + dup tuple-class? [ + dup inlined-dependency depends-on + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append >quotation + ] [ drop f ] if ; + +\ new [ inline-new ] 1 define-partial-eval + +\ instance? [ + dup class? + [ "predicate" word-prop ] [ drop f ] if +] 1 define-partial-eval + +! Shuffling +: nths-quot ( indices -- quot ) + [ [ '[ _ swap nth ] ] map ] [ length ] bi + '[ _ cleave _ narray ] ; + +\ shuffle [ + shuffle-mapping nths-quot +] 1 define-partial-eval + +! Index search +\ index [ + dup sequence? [ + dup length 4 >= [ + dup length zip >hashtable '[ _ at ] + ] [ drop f ] if + ] [ drop f ] if +] 1 define-partial-eval + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ cond ] curry ; + +\ memq? [ + dup sequence? [ memq-quot ] [ drop f ] if +] 1 define-partial-eval + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry + ] if ; + +\ member? [ + dup sequence? [ member-quot ] [ drop f ] if +] 1 define-partial-eval + +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 + +: lookup-table-at? ( assoc -- ? ) + #! Can we use a fast byte array test here? + { + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] + } 1&& ; + +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; + +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot + ] [ + lookup-table-quot + ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-partial-eval diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ac276b6e41..c21be39adb 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -27,4 +27,6 @@ SYMBOL: yield-hook yield-hook [ [ ] ] initialize : alist-max ( alist -- pair ) - [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; \ No newline at end of file + [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; + +: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 9d1ab1332a..056eda8b61 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -107,97 +107,3 @@ IN: stack-checker.transforms ] 1 define-transform \ boa t "no-compile" set-word-prop - -! Fast at for integer maps -CONSTANT: lookup-table-at-max 256 - -: lookup-table-at? ( assoc -- ? ) - #! Can we use a fast byte array test here? - { - [ assoc-size 4 > ] - [ values [ ] all? ] - [ keys [ integer? ] all? ] - [ keys [ 0 lookup-table-at-max between? ] all? ] - } 1&& ; - -: lookup-table-seq ( assoc -- table ) - [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; - -: lookup-table-quot ( seq -- newquot ) - lookup-table-seq - '[ - _ over integer? [ - 2dup bounds-check? [ - nth-unsafe dup >boolean - ] [ 2drop f f ] if - ] [ 2drop f f ] if - ] ; - -: fast-lookup-table-at? ( assoc -- ? ) - values { - [ [ integer? ] all? ] - [ [ 0 254 between? ] all? ] - } 1&& ; - -: fast-lookup-table-seq ( assoc -- table ) - lookup-table-seq [ 255 or ] B{ } map-as ; - -: fast-lookup-table-quot ( seq -- newquot ) - fast-lookup-table-seq - '[ - _ over integer? [ - 2dup bounds-check? [ - nth-unsafe dup 255 eq? [ drop f f ] [ t ] if - ] [ 2drop f f ] if - ] [ 2drop f f ] if - ] ; - -: at-quot ( assoc -- quot ) - dup lookup-table-at? [ - dup fast-lookup-table-at? [ - fast-lookup-table-quot - ] [ - lookup-table-quot - ] if - ] [ drop f ] if ; - -\ at* [ at-quot ] 1 define-transform - -! Membership testing -: member-quot ( seq -- newquot ) - dup length 4 <= [ - [ drop f ] swap - [ literalize [ t ] ] { } map>assoc linear-case-quot - ] [ - unique [ key? ] curry - ] if ; - -\ member? [ - dup sequence? [ member-quot ] [ drop f ] if -] 1 define-transform - -: memq-quot ( seq -- newquot ) - [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc - [ drop f ] suffix [ cond ] curry ; - -\ memq? [ - dup sequence? [ memq-quot ] [ drop f ] if -] 1 define-transform - -! Index search -\ index [ - dup sequence? [ - dup length 4 >= [ - dup length zip >hashtable '[ _ at ] - ] [ drop f ] if - ] [ drop f ] if -] 1 define-transform - -! Shuffling -: nths-quot ( indices -- quot ) - [ [ '[ _ swap nth ] ] map ] [ length ] bi - '[ _ cleave _ narray ] ; - -\ shuffle [ - shuffle-mapping nths-quot -] 1 define-transform diff --git a/basis/alien/inline/authors.txt b/extra/alien/inline/authors.txt similarity index 100% rename from basis/alien/inline/authors.txt rename to extra/alien/inline/authors.txt diff --git a/basis/alien/inline/compiler/authors.txt b/extra/alien/inline/compiler/authors.txt similarity index 100% rename from basis/alien/inline/compiler/authors.txt rename to extra/alien/inline/compiler/authors.txt diff --git a/extra/alien/inline/compiler/compiler-docs.factor b/extra/alien/inline/compiler/compiler-docs.factor new file mode 100644 index 0000000000..28e2538e1f --- /dev/null +++ b/extra/alien/inline/compiler/compiler-docs.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel strings words.symbol sequences ; +IN: alien.inline.compiler + +HELP: C +{ $var-description "A symbol representing C source." } ; + +HELP: C++ +{ $var-description "A symbol representing C++ source." } ; + +HELP: compile-to-library +{ $values + { "lang" symbol } { "args" sequence } { "contents" string } { "name" string } +} +{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" } + "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. " + { $snippet "args" } " is a sequence of arguments for the linking stage." } +{ $notes + { $list + "C and C++ are the only supported languages." + { "Source and object files are placed in " { $snippet "resource:temp" } "." } } +} ; + +HELP: compiler +{ $values + { "lang" symbol } + { "str" string } +} +{ $description "Returns a compiler name based on OS and source language." } +{ $see-also compiler-descr } ; + +HELP: compiler-descr +{ $values + { "lang" symbol } + { "descr" "a process description" } +} +{ $description "Returns a compiler process description based on OS and source language." } +{ $see-also compiler } ; + +HELP: inline-library-file +{ $values + { "name" string } + { "path" "a pathname string" } +} +{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ; + +HELP: inline-libs-directory +{ $values + { "path" "a pathname string" } +} +{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ; + +HELP: library-path +{ $values + { "str" string } + { "path" "a pathname string" } +} +{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ; + +HELP: library-suffix +{ $values + { "str" string } +} +{ $description "The appropriate shared library suffix for the current OS." } ; + +HELP: link-descr +{ $values + { "descr" sequence } +} +{ $description "Returns part of a process description. OS dependent." } ; + +ARTICLE: "alien.inline.compiler" "Inline C compiler" +{ $vocab-link "alien.inline.compiler" } +; + +ABOUT: "alien.inline.compiler" diff --git a/basis/alien/inline/compiler/compiler.factor b/extra/alien/inline/compiler/compiler.factor similarity index 77% rename from basis/alien/inline/compiler/compiler.factor rename to extra/alien/inline/compiler/compiler.factor index d7d2d6fc43..7ec70a356e 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/extra/alien/inline/compiler/compiler.factor @@ -22,35 +22,37 @@ SYMBOL: C++ { [ dup windows? ] [ drop ".dll" ] } } cond ; -: library-path ( str -- str' ) - '[ "lib" % _ % library-suffix % ] "" make temp-file ; - -: src-suffix ( lang -- str ) - { - { C [ ".c" ] } - { C++ [ ".cpp" ] } - } case ; +: library-path ( str -- path ) + '[ "lib" % _ % library-suffix % ] "" make inline-library-file ; HOOK: compiler os ( lang -- str ) -M: word compiler ( lang -- str ) +M: word compiler { { C [ "gcc" ] } { C++ [ "g++" ] } } case ; -M: openbsd compiler ( lang -- str ) +M: openbsd compiler { { C [ "gcc" ] } { C++ [ "eg++" ] } } case ; +M: windows compiler + { + { C [ "gcc" ] } + { C++ [ "gcc" ] } + } case ; + HOOK: compiler-descr os ( lang -- descr ) M: word compiler-descr compiler 1array ; M: macosx compiler-descr call-next-method cpu x86.64? [ { "-arch" "x86_64" } append ] when ; +M: windows compiler-descr + call-next-method { "-x" "c++" } append ; HOOK: link-descr os ( -- descr ) @@ -58,9 +60,18 @@ M: word link-descr { "-shared" "-o" } ; M: macosx link-descr { "-g" "-prebind" "-dynamiclib" "-o" } cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ; +M: windows link-descr { "-lstdc++" "-mno-cygwin" "-o" } ; -: link-command ( in out lang -- descr ) - compiler-descr link-descr append prepend prepend ; + :: compile-to-library ( lang args contents name -- ) lang contents name compile-to-object diff --git a/basis/alien/inline/inline-docs.factor b/extra/alien/inline/inline-docs.factor similarity index 53% rename from basis/alien/inline/inline-docs.factor rename to extra/alien/inline/inline-docs.factor index 58eca558ea..2c0cd28745 100644 --- a/basis/alien/inline/inline-docs.factor +++ b/extra/alien/inline/inline-docs.factor @@ -3,108 +3,12 @@ USING: help.markup help.syntax kernel strings effects quotations ; IN: alien.inline + HELP: compile-c-library { $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". " @@ -204,8 +108,6 @@ HELP: with-c-library } { $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ; -ARTICLE: "alien.inline" "Inline C" -{ $vocab-link "alien.inline" } -; - -ABOUT: "alien.inline" +HELP: raw-c +{ $values { "str" string } } +{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; diff --git a/basis/alien/inline/inline.factor b/extra/alien/inline/inline.factor similarity index 80% rename from basis/alien/inline/inline.factor rename to extra/alien/inline/inline.factor index 1df77d6600..62c6102a86 100644 --- a/basis/alien/inline/inline.factor +++ b/extra/alien/inline/inline.factor @@ -9,43 +9,20 @@ splitting strings system vocabs.loader vocabs.parser words alien.c-types alien.structs make parser continuations ; IN: alien.inline -params-return factorize-type -roll - concat make-function ; - -: prototype-string ( function types effect -- str ) - [ [ cify-type ] map ] dip - types-effect>params-return cify-type -rot - [ " " join ] map ", " join - "(" prepend ")" append 3array " " join - library-is-c++ get [ "extern \"C\" " prepend ] when ; - -: prototype-string' ( function types return -- str ) - [ dup arg-list ] prototype-string ; - -: append-function-body ( prototype-str body -- str ) - [ swap % " {\n" % % "\n}\n" % ] "" make ; - : compile-library? ( -- ? ) c-library get library-path dup exists? [ file get [ @@ -56,7 +33,7 @@ SYMBOL: c-strings : compile-library ( -- ) library-is-c++ get [ C++ ] [ C ] if - compiler-args get + linker-args get c-strings get "\n" join c-library get compile-to-library ; @@ -64,10 +41,33 @@ SYMBOL: c-strings [ current-vocab name>> % "_" % % ] "" make ; PRIVATE> +: append-function-body ( prototype-str body -- str ) + [ swap % " {\n" % % "\n}\n" % ] "" make ; + +: function-types-effect ( -- function types effect ) + scan scan swap ")" parse-tokens + [ "(" subseq? not ] filter swap parse-arglist ; + +: prototype-string ( function types effect -- str ) + [ [ cify-type ] map ] dip + types-effect>params-return cify-type -rot + [ " " join ] map ", " join + "(" prepend ")" append 3array " " join + library-is-c++ get [ "extern \"C\" " prepend ] when ; + +: prototype-string' ( function types return -- str ) + [ dup arg-list ] prototype-string ; + +: factor-function ( function types effect -- word quot effect ) + annotate-effect [ c-library get ] 3dip + [ [ factorize-type ] map ] dip + types-effect>params-return factorize-type -roll + concat make-function ; + : define-c-library ( name -- ) c-library-name c-library set V{ } clone c-strings set - V{ } clone compiler-args set ; + V{ } clone linker-args set ; : compile-c-library ( -- ) compile-library? [ compile-library ] when @@ -87,10 +87,10 @@ PRIVATE> ] dip append-function-body c-strings get push ; : c-link-to ( str -- ) - "-l" prepend compiler-args get push ; + "-l" prepend linker-args get push ; : c-use-framework ( str -- ) - "-framework" swap compiler-args get '[ _ push ] bi@ ; + "-framework" swap linker-args get '[ _ push ] bi@ ; : c-link-to/use-framework ( str -- ) os macosx? [ c-use-framework ] [ c-link-to ] if ; @@ -122,29 +122,5 @@ PRIVATE> [ [ define-c-library ] dip call compile-c-library ] [ cleanup-variables ] [ ] cleanup ; inline -SYNTAX: C-LIBRARY: scan define-c-library ; - -SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; - -SYNTAX: C-LINK: scan c-link-to ; - -SYNTAX: C-FRAMEWORK: scan c-use-framework ; - -SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ; - -SYNTAX: C-INCLUDE: scan c-include ; - -SYNTAX: C-FUNCTION: - function-types-effect parse-here define-c-function ; - -SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; - -SYNTAX: C-STRUCTURE: - scan parse-definition define-c-struct ; - -SYNTAX: ;C-LIBRARY compile-c-library ; - -SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; - -SYNTAX: RAW-C: - [ "\n" % parse-here % "\n" % c-strings get push ] "" make ; +: raw-c ( str -- ) + [ "\n" % % "\n" % ] "" make c-strings get push ; diff --git a/basis/alien/inline/types/authors.txt b/extra/alien/inline/syntax/authors.txt similarity index 100% rename from basis/alien/inline/types/authors.txt rename to extra/alien/inline/syntax/authors.txt diff --git a/extra/alien/inline/syntax/syntax-docs.factor b/extra/alien/inline/syntax/syntax-docs.factor new file mode 100644 index 0000000000..0fc5a5140b --- /dev/null +++ b/extra/alien/inline/syntax/syntax-docs.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax alien.inline ; +IN: alien.inline.syntax + +HELP: ;C-LIBRARY +{ $syntax ";C-LIBRARY" } +{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." } +{ $see-also POSTPONE: compile-c-library } ; + +HELP: C-FRAMEWORK: +{ $syntax "C-FRAMEWORK: name" } +{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } +{ $see-also POSTPONE: c-use-framework } ; + +HELP: C-FUNCTION: +{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" } +{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." } +{ $examples + { $example + "USING: alien.inline.syntax prettyprint ;" + "IN: cmath.ffi" + "" + "C-LIBRARY: cmathlib" + "" + "C-FUNCTION: int add ( int a, int b )" + " return a + b;" + ";" + "" + ";C-LIBRARY" + "" + "1 2 add ." + "3" } +} +{ $see-also POSTPONE: define-c-function } ; + +HELP: C-INCLUDE: +{ $syntax "C-INCLUDE: name" } +{ $description "Appends an include line to the C library in scope." } +{ $see-also POSTPONE: c-include } ; + +HELP: C-LIBRARY: +{ $syntax "C-LIBRARY: name" } +{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." } +{ $examples + { $example + "USING: alien.inline.syntax ;" + "IN: rectangle.ffi" + "" + "C-LIBRARY: rectlib" + "" + "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;" + "" + "C-FUNCTION: int area ( rectangle c )" + " return c.width * c.height;" + ";" + "" + ";C-LIBRARY" + "" } +} +{ $see-also POSTPONE: define-c-library } ; + +HELP: C-LINK/FRAMEWORK: +{ $syntax "C-LINK/FRAMEWORK: name" } +{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." } +{ $see-also POSTPONE: c-link-to/use-framework } ; + +HELP: C-LINK: +{ $syntax "C-LINK: name" } +{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } +{ $see-also POSTPONE: c-link-to } ; + +HELP: C-STRUCTURE: +{ $syntax "C-STRUCTURE: name pairs ... ;" } +{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."} +{ $see-also POSTPONE: define-c-struct } ; + +HELP: C-TYPEDEF: +{ $syntax "C-TYPEDEF: old new" } +{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." } +{ $see-also POSTPONE: define-c-typedef } ; + +HELP: COMPILE-AS-C++ +{ $syntax "COMPILE-AS-C++" } +{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ; + +HELP: DELETE-C-LIBRARY: +{ $syntax "DELETE-C-LIBRARY: name" } +{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " } +{ $notes + { $list + { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } + "This word is mainly useful for unit tests." + } +} +{ $see-also POSTPONE: delete-inline-library } ; + +HELP: RAW-C: +{ $syntax "RAW-C:" "body" ";" } +{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; diff --git a/basis/alien/inline/inline-tests.factor b/extra/alien/inline/syntax/syntax-tests.factor similarity index 93% rename from basis/alien/inline/inline-tests.factor rename to extra/alien/inline/syntax/syntax-tests.factor index 09b76a4bb5..e6a0b8b7d8 100644 --- a/basis/alien/inline/inline-tests.factor +++ b/extra/alien/inline/syntax/syntax-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.inline alien.inline.private io.directories io.files +USING: alien.inline alien.inline.syntax io.directories io.files kernel namespaces tools.test alien.c-types alien.structs ; -IN: alien.inline.tests +IN: alien.inline.syntax.tests DELETE-C-LIBRARY: test C-LIBRARY: test diff --git a/extra/alien/inline/syntax/syntax.factor b/extra/alien/inline/syntax/syntax.factor new file mode 100644 index 0000000000..6cef56f9b2 --- /dev/null +++ b/extra/alien/inline/syntax/syntax.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.inline lexer multiline namespaces parser ; +IN: alien.inline.syntax + + +SYNTAX: C-LIBRARY: scan define-c-library ; + +SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; + +SYNTAX: C-LINK: scan c-link-to ; + +SYNTAX: C-FRAMEWORK: scan c-use-framework ; + +SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ; + +SYNTAX: C-INCLUDE: scan c-include ; + +SYNTAX: C-FUNCTION: + function-types-effect parse-here define-c-function ; + +SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; + +SYNTAX: C-STRUCTURE: + scan parse-definition define-c-struct ; + +SYNTAX: ;C-LIBRARY compile-c-library ; + +SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; + +SYNTAX: RAW-C: parse-here raw-c ; diff --git a/extra/alien/inline/types/authors.txt b/extra/alien/inline/types/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/inline/types/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor similarity index 65% rename from basis/alien/inline/types/types.factor rename to extra/alien/inline/types/types.factor index acc62a81a2..94b98d1eb5 100644 --- a/basis/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -5,16 +5,21 @@ continuations effects fry kernel math memoize sequences splitting ; IN: alien.inline.types -: factorize-type ( str -- str' ) - "const-" ?head drop - "unsigned-" ?head [ "u" prepend ] when - "long-" ?head [ "long" prepend ] when ; - : cify-type ( str -- str' ) { { CHAR: - CHAR: space } } substitute ; -: const-type? ( str -- ? ) - "const-" head? ; +: factorize-type ( str -- str' ) + cify-type + "const " ?head drop + "unsigned " ?head [ "u" prepend ] when + "long " ?head [ "long" prepend ] when + " const" ?tail drop ; + +: const-pointer? ( str -- ? ) + cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ; + +: pointer-to-const? ( str -- ? ) + cify-type "const " head? ; MEMO: resolved-primitives ( -- seq ) primitive-types [ resolve-typedef ] map ; @@ -26,14 +31,21 @@ MEMO: resolved-primitives ( -- seq ) ] [ 2drop f ] recover ; : pointer? ( type -- ? ) - [ "*" tail? ] [ "&" tail? ] bi or ; + factorize-type [ "*" tail? ] [ "&" tail? ] bi or ; : type-sans-pointer ( type -- type' ) - [ '[ _ = ] "*&" swap any? ] trim-tail ; + factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ; : pointer-to-primitive? ( type -- ? ) + factorize-type { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; +: pointer-to-non-const-primitive? ( str -- ? ) + { + [ pointer-to-const? not ] + [ factorize-type pointer-to-primitive? ] + } 1&& ; + : types-effect>params-return ( types effect -- params return ) [ in>> zip ] [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] diff --git a/extra/alien/marshall/authors.txt b/extra/alien/marshall/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/marshall/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor new file mode 100644 index 0000000000..6002b0c1c3 --- /dev/null +++ b/extra/alien/marshall/marshall-docs.factor @@ -0,0 +1,638 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences +strings alien alien.c-types math byte-arrays ; +IN: alien.marshall + + + +HELP: ?malloc-byte-array +{ $values + { "c-type" c-type } + { "alien" alien } +} +{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls " + { $snippet "malloc-byte-array" } "." +} +{ $notes $memory-note } ; + +HELP: alien-wrapper +{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ; + +HELP: unmarshall-cast +{ $values + { "alien-wrapper" alien-wrapper } + { "alien-wrapper'" alien-wrapper } +} +{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ; + +HELP: marshall-bool +{ $values + { "?" "a generalized boolean" } + { "n" "0 or 1" } +} +{ $description "Marshalls objects to bool." } +{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ; + +HELP: marshall-bool* +{ $values + { "?/seq" "t/f or sequence" } + { "alien" alien } +} +{ $description "When the argument is a sequence, returns a pointer to an array of bool, " + "otherwise returns a pointer to a single bool value." +} +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-bool** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description "Takes a one or two dimensional array of generalized booleans " + "and returns a pointer to the equivalent C structure." +} +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-primitive +{ $values + { "n" number } + { "n" number } +} +{ $description "Marshall numbers to C primitives." + $nl + "Factor marshalls numbers to primitives for FFI calls, so all " + "this word does is convert " { $snippet "t" } " to " { $snippet "1" } + ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else " + "pass through untouched." +} ; + +HELP: marshall-char* +{ $values + { "n/seq" "number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-char** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-char**-or-strings +{ $values + { "seq" "a sequence of strings" } + { "alien" alien } +} +{ $description "Marshalls an array of strings or characters to an array of C strings." } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-char*-or-string +{ $values + { "n/string" "a number or string" } + { "alien" alien } +} +{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-double* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-double** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-float* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-float** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-int* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-int** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-long* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-long** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-longlong* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-longlong** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-non-pointer +{ $values + { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" } + { "byte-array" byte-array } +} +{ $description "Converts argument to a byte array." } +{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ; + +HELP: marshall-pointer +{ $values + { "obj" object } + { "alien" alien } +} +{ $description "Converts argument to a C pointer." } +{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ; + +HELP: marshall-short* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-short** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uchar* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uchar** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uint* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uint** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulong* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulong** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulonglong* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulonglong** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ushort* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ushort** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-void** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description "Marshalls a sequence of objects to an array of pointers to void." } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ; + +HELP: out-arg-unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Like " { $link unmarshaller } " but returns an empty quotation " + "for all types except pointers to non-const primitives." +} ; + +HELP: pointer-unmarshaller +{ $values + { "type" " a C type string" } + { "quot" quotation } +} +{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper } + " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which " + "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation." +} +{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ; + +HELP: primitive-marshaller +{ $values + { "type" "a C type string" } + { "quot/f" "a quotation or f" } +} +{ $description "Returns a quotation to marshall objects to the argument type." } +{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ; + +HELP: primitive-unmarshaller +{ $values + { "type" "a C type string" } + { "quot/f" "a quotation or f" } +} +{ $description "Returns a quotation to unmarshall objects from the argument type." } +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-field-unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Like " { $link unmarshaller } " but returns a quotation that " + "does not call " { $snippet "free" } " on its argument." +} +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-primitive-unmarshaller +{ $values + { "type" "a C type string" } + { "quot/f" "a quotation or f" } +} +{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that " + "does not call " { $snippet "free" } " on its argument." } +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Returns a quotation which wraps its argument in the subclass of " + { $link struct-wrapper } " which matches the " { $snippet "type" } " arg." +} +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-wrapper +{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ; + +HELP: unmarshall-bool +{ $values + { "n" number } + { "?" "a boolean" } +} +{ $description "Unmarshalls a number to a boolean." } ; + +HELP: unmarshall-bool* +{ $values + { "alien" alien } + { "?" "a boolean" } +} +{ $description "Unmarshalls a C pointer to a boolean." } ; + +HELP: unmarshall-bool*-free +{ $values + { "alien" alien } + { "?" "a boolean" } +} +{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ; + +HELP: unmarshall-char* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-char*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-char*-to-string +{ $values + { "alien" alien } + { "string" string } +} +{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ; + +HELP: unmarshall-char*-to-string-free +{ $values + { "alien" alien } + { "string" string } +} +{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ; + +HELP: unmarshall-double* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-double*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-float* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-float*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-int* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-int*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-long* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-long*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-longlong* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-longlong*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-short* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-short*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uchar* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uchar*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uint* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uint*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulong* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulong*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulonglong* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulonglong*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ushort* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ushort*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ; + +ARTICLE: "alien.marshall" "C marshalling" +{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the " +"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters." + +{ $subheading "Important words" } +"Wrap an alien:" { $subsection alien-wrapper } +"Wrap a struct:" { $subsection struct-wrapper } +"Get the marshaller for a C type:" { $subsection marshaller } +"Get the unmarshaller for a C type:" { $subsection marshaller } +"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller } +"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller } +$nl +"Other marshalling and unmarshalling words in this vocabulary are not intended to be " +"invoked directly." +$nl +"Most marshalling words allow non false c-ptrs to pass through unchanged." + +{ $subheading "Primitive marshallers" } +{ $subsection marshall-primitive } "for marshalling primitive values." +{ $subsection marshall-int* } + "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer " + "to a C array, otherwise returns a pointer to a single value." +{ $subsection marshall-int** } +"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays." + +{ $subheading "Primitive unmarshallers" } +{ $snippet "unmarshall-*" } " and " { $snippet "unmarshall-*-free" } +" for all values of " { $snippet "" } " in " { $link primitive-types } "." +{ $subsection unmarshall-int* } +"unmarshalls a pointer to primitive. Returns a number. " +"Assumes the pointer is not an array (if it is, only the first value is returned). " +"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" } +" and must be unmarshalled by hand." +{ $subsection unmarshall-int*-free } +"unmarshalls a pointer to primitive, and then frees the pointer." +$nl +"Primitive values require no unmarshalling. The factor FFI already does this." +; + +ABOUT: "alien.marshall" diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor new file mode 100644 index 0000000000..85b157e4a0 --- /dev/null +++ b/extra/alien/marshall/marshall.factor @@ -0,0 +1,303 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.inline.types +alien.marshall.private alien.strings byte-arrays classes +combinators combinators.short-circuit destructors fry +io.encodings.utf8 kernel libc sequences +specialized-arrays.alien specialized-arrays.bool +specialized-arrays.char specialized-arrays.double +specialized-arrays.float specialized-arrays.int +specialized-arrays.long specialized-arrays.longlong +specialized-arrays.short specialized-arrays.uchar +specialized-arrays.uint specialized-arrays.ulong +specialized-arrays.ulonglong specialized-arrays.ushort strings +unix.utilities vocabs.parser words libc.private struct-arrays ; +IN: alien.marshall + +<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] +filter [ define-primitive-marshallers ] each >> + +TUPLE: alien-wrapper { underlying alien } ; +TUPLE: struct-wrapper < alien-wrapper disposed ; + +GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' ) + +M: alien-wrapper unmarshall-cast ; +M: struct-wrapper unmarshall-cast ; + +M: struct-wrapper dispose* underlying>> free ; + +: marshall-pointer ( obj -- alien ) + { + { [ dup alien? ] [ ] } + { [ dup not ] [ ] } + { [ dup byte-array? ] [ malloc-byte-array ] } + { [ dup alien-wrapper? ] [ underlying>> ] } + { [ dup struct-array? ] [ underlying>> ] } + } cond ; + +: marshall-primitive ( n -- n ) + [ bool>arg ] ptr-pass-through ; + +ALIAS: marshall-void* marshall-pointer + +: marshall-void** ( seq -- alien ) + [ marshall-void* ] void*-array{ } map-as malloc-underlying ; + +: (marshall-char*-or-string) ( n/string -- alien ) + dup string? + [ utf8 string>alien malloc-byte-array ] + [ (marshall-char*) ] if ; + +: marshall-char*-or-string ( n/string -- alien ) + [ (marshall-char*-or-string) ] ptr-pass-through ; + +: (marshall-char**-or-strings) ( seq -- alien ) + [ marshall-char*-or-string ] void*-array{ } map-as + malloc-underlying ; + +: marshall-char**-or-strings ( seq -- alien ) + [ (marshall-char**-or-strings) ] ptr-pass-through ; + +: marshall-bool ( ? -- n ) + >boolean [ 1 ] [ 0 ] if ; + +: (marshall-bool*) ( ?/seq -- alien ) + [ marshall-bool malloc-byte-array ] + [ >bool-array malloc-underlying ] + marshall-x* ; + +: marshall-bool* ( ?/seq -- alien ) + [ (marshall-bool*) ] ptr-pass-through ; + +: (marshall-bool**) ( seq -- alien ) + [ marshall-bool* ] map >void*-array malloc-underlying ; + +: marshall-bool** ( seq -- alien ) + [ (marshall-bool**) ] ptr-pass-through ; + +: unmarshall-bool ( n -- ? ) + 0 = not ; + +: unmarshall-bool* ( alien -- ? ) + *bool unmarshall-bool ; + +: unmarshall-bool*-free ( alien -- ? ) + [ *bool unmarshall-bool ] keep add-malloc free ; + +: primitive-marshaller ( type -- quot/f ) + { + { "bool" [ [ marshall-bool ] ] } + { "boolean" [ [ marshall-bool ] ] } + { "char" [ [ marshall-primitive ] ] } + { "uchar" [ [ marshall-primitive ] ] } + { "short" [ [ marshall-primitive ] ] } + { "ushort" [ [ marshall-primitive ] ] } + { "int" [ [ marshall-primitive ] ] } + { "uint" [ [ marshall-primitive ] ] } + { "long" [ [ marshall-primitive ] ] } + { "ulong" [ [ marshall-primitive ] ] } + { "long" [ [ marshall-primitive ] ] } + { "ulong" [ [ marshall-primitive ] ] } + { "float" [ [ marshall-primitive ] ] } + { "double" [ [ marshall-primitive ] ] } + { "bool*" [ [ marshall-bool* ] ] } + { "boolean*" [ [ marshall-bool* ] ] } + { "char*" [ [ marshall-char*-or-string ] ] } + { "uchar*" [ [ marshall-uchar* ] ] } + { "short*" [ [ marshall-short* ] ] } + { "ushort*" [ [ marshall-ushort* ] ] } + { "int*" [ [ marshall-int* ] ] } + { "uint*" [ [ marshall-uint* ] ] } + { "long*" [ [ marshall-long* ] ] } + { "ulong*" [ [ marshall-ulong* ] ] } + { "longlong*" [ [ marshall-longlong* ] ] } + { "ulonglong*" [ [ marshall-ulonglong* ] ] } + { "float*" [ [ marshall-float* ] ] } + { "double*" [ [ marshall-double* ] ] } + { "bool&" [ [ marshall-bool* ] ] } + { "boolean&" [ [ marshall-bool* ] ] } + { "char&" [ [ marshall-char* ] ] } + { "uchar&" [ [ marshall-uchar* ] ] } + { "short&" [ [ marshall-short* ] ] } + { "ushort&" [ [ marshall-ushort* ] ] } + { "int&" [ [ marshall-int* ] ] } + { "uint&" [ [ marshall-uint* ] ] } + { "long&" [ [ marshall-long* ] ] } + { "ulong&" [ [ marshall-ulong* ] ] } + { "longlong&" [ [ marshall-longlong* ] ] } + { "ulonglong&" [ [ marshall-ulonglong* ] ] } + { "float&" [ [ marshall-float* ] ] } + { "double&" [ [ marshall-double* ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool** ] ] } + { "boolean**" [ [ marshall-bool** ] ] } + { "char**" [ [ marshall-char**-or-strings ] ] } + { "uchar**" [ [ marshall-uchar** ] ] } + { "short**" [ [ marshall-short** ] ] } + { "ushort**" [ [ marshall-ushort** ] ] } + { "int**" [ [ marshall-int** ] ] } + { "uint**" [ [ marshall-uint** ] ] } + { "long**" [ [ marshall-long** ] ] } + { "ulong**" [ [ marshall-ulong** ] ] } + { "longlong**" [ [ marshall-longlong** ] ] } + { "ulonglong**" [ [ marshall-ulonglong** ] ] } + { "float**" [ [ marshall-float** ] ] } + { "double**" [ [ marshall-double** ] ] } + { "void**" [ [ marshall-void** ] ] } + [ drop f ] + } case ; + +: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array ) + { + { [ dup byte-array? ] [ ] } + { [ dup alien-wrapper? ] + [ [ underlying>> ] [ class name>> heap-size ] bi + memory>byte-array ] } + } cond ; + + +: marshaller ( type -- quot ) + factorize-type dup primitive-marshaller [ nip ] [ + pointer? + [ [ marshall-pointer ] ] + [ [ marshall-non-pointer ] ] if + ] if* ; + + +: unmarshall-char*-to-string ( alien -- string ) + utf8 alien>string ; + +: unmarshall-char*-to-string-free ( alien -- string ) + [ unmarshall-char*-to-string ] keep add-malloc free ; + +: primitive-unmarshaller ( type -- quot/f ) + { + { "bool" [ [ unmarshall-bool ] ] } + { "boolean" [ [ unmarshall-bool ] ] } + { "char" [ [ ] ] } + { "uchar" [ [ ] ] } + { "short" [ [ ] ] } + { "ushort" [ [ ] ] } + { "int" [ [ ] ] } + { "uint" [ [ ] ] } + { "long" [ [ ] ] } + { "ulong" [ [ ] ] } + { "longlong" [ [ ] ] } + { "ulonglong" [ [ ] ] } + { "float" [ [ ] ] } + { "double" [ [ ] ] } + { "bool*" [ [ unmarshall-bool*-free ] ] } + { "boolean*" [ [ unmarshall-bool*-free ] ] } + { "char*" [ [ ] ] } + { "uchar*" [ [ unmarshall-uchar*-free ] ] } + { "short*" [ [ unmarshall-short*-free ] ] } + { "ushort*" [ [ unmarshall-ushort*-free ] ] } + { "int*" [ [ unmarshall-int*-free ] ] } + { "uint*" [ [ unmarshall-uint*-free ] ] } + { "long*" [ [ unmarshall-long*-free ] ] } + { "ulong*" [ [ unmarshall-ulong*-free ] ] } + { "longlong*" [ [ unmarshall-long*-free ] ] } + { "ulonglong*" [ [ unmarshall-ulong*-free ] ] } + { "float*" [ [ unmarshall-float*-free ] ] } + { "double*" [ [ unmarshall-double*-free ] ] } + { "bool&" [ [ unmarshall-bool*-free ] ] } + { "boolean&" [ [ unmarshall-bool*-free ] ] } + { "char&" [ [ ] ] } + { "uchar&" [ [ unmarshall-uchar*-free ] ] } + { "short&" [ [ unmarshall-short*-free ] ] } + { "ushort&" [ [ unmarshall-ushort*-free ] ] } + { "int&" [ [ unmarshall-int*-free ] ] } + { "uint&" [ [ unmarshall-uint*-free ] ] } + { "long&" [ [ unmarshall-long*-free ] ] } + { "ulong&" [ [ unmarshall-ulong*-free ] ] } + { "longlong&" [ [ unmarshall-longlong*-free ] ] } + { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] } + { "float&" [ [ unmarshall-float*-free ] ] } + { "double&" [ [ unmarshall-double*-free ] ] } + [ drop f ] + } case ; + +: struct-primitive-unmarshaller ( type -- quot/f ) + { + { "bool" [ [ unmarshall-bool ] ] } + { "boolean" [ [ unmarshall-bool ] ] } + { "char" [ [ ] ] } + { "uchar" [ [ ] ] } + { "short" [ [ ] ] } + { "ushort" [ [ ] ] } + { "int" [ [ ] ] } + { "uint" [ [ ] ] } + { "long" [ [ ] ] } + { "ulong" [ [ ] ] } + { "longlong" [ [ ] ] } + { "ulonglong" [ [ ] ] } + { "float" [ [ ] ] } + { "double" [ [ ] ] } + { "bool*" [ [ unmarshall-bool* ] ] } + { "boolean*" [ [ unmarshall-bool* ] ] } + { "char*" [ [ ] ] } + { "uchar*" [ [ unmarshall-uchar* ] ] } + { "short*" [ [ unmarshall-short* ] ] } + { "ushort*" [ [ unmarshall-ushort* ] ] } + { "int*" [ [ unmarshall-int* ] ] } + { "uint*" [ [ unmarshall-uint* ] ] } + { "long*" [ [ unmarshall-long* ] ] } + { "ulong*" [ [ unmarshall-ulong* ] ] } + { "longlong*" [ [ unmarshall-long* ] ] } + { "ulonglong*" [ [ unmarshall-ulong* ] ] } + { "float*" [ [ unmarshall-float* ] ] } + { "double*" [ [ unmarshall-double* ] ] } + { "bool&" [ [ unmarshall-bool* ] ] } + { "boolean&" [ [ unmarshall-bool* ] ] } + { "char&" [ [ unmarshall-char* ] ] } + { "uchar&" [ [ unmarshall-uchar* ] ] } + { "short&" [ [ unmarshall-short* ] ] } + { "ushort&" [ [ unmarshall-ushort* ] ] } + { "int&" [ [ unmarshall-int* ] ] } + { "uint&" [ [ unmarshall-uint* ] ] } + { "long&" [ [ unmarshall-long* ] ] } + { "ulong&" [ [ unmarshall-ulong* ] ] } + { "longlong&" [ [ unmarshall-longlong* ] ] } + { "ulonglong&" [ [ unmarshall-ulonglong* ] ] } + { "float&" [ [ unmarshall-float* ] ] } + { "double&" [ [ unmarshall-double* ] ] } + [ drop f ] + } case ; + + +: ?malloc-byte-array ( c-type -- alien ) + dup alien? [ malloc-byte-array ] unless ; + +: struct-unmarshaller ( type -- quot ) + current-vocab lookup [ + dup superclasses [ \ struct-wrapper = ] any? [ + '[ ?malloc-byte-array _ new swap >>underlying ] + ] [ drop [ ] ] if + ] [ [ ] ] if* ; + +: pointer-unmarshaller ( type -- quot ) + type-sans-pointer current-vocab lookup [ + dup superclasses [ \ alien-wrapper = ] any? [ + '[ _ new swap >>underlying unmarshall-cast ] + ] [ drop [ ] ] if + ] [ [ ] ] if* ; + +: unmarshaller ( type -- quot ) + factorize-type dup primitive-unmarshaller [ nip ] [ + dup pointer? + [ pointer-unmarshaller ] + [ struct-unmarshaller ] if + ] if* ; + +: struct-field-unmarshaller ( type -- quot ) + factorize-type dup struct-primitive-unmarshaller [ nip ] [ + dup pointer? + [ pointer-unmarshaller ] + [ struct-unmarshaller ] if + ] if* ; + +: out-arg-unmarshaller ( type -- quot ) + dup pointer-to-non-const-primitive? + [ factorize-type primitive-unmarshaller ] + [ drop [ drop ] ] if ; diff --git a/extra/alien/marshall/private/authors.txt b/extra/alien/marshall/private/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/marshall/private/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/marshall/private/private.factor b/extra/alien/marshall/private/private.factor new file mode 100644 index 0000000000..70b03e2bab --- /dev/null +++ b/extra/alien/marshall/private/private.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.inline arrays +combinators fry functors kernel lexer libc macros math +sequences specialized-arrays.alien libc.private +combinators.short-circuit ; +IN: alien.marshall.private + +: bool>arg ( ? -- 1/0/obj ) + { + { t [ 1 ] } + { f [ 0 ] } + [ ] + } case ; + +MACRO: marshall-x* ( num-quot seq-quot -- alien ) + '[ bool>arg dup number? _ _ if ] ; + +: ptr-pass-through ( obj quot -- alien ) + over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline + +: malloc-underlying ( obj -- alien ) + underlying>> malloc-byte-array ; + +FUNCTOR: define-primitive-marshallers ( TYPE -- ) + IS <${TYPE}> +*TYPE IS *${TYPE} +>TYPE-array IS >${TYPE}-array +marshall-TYPE DEFINES marshall-${TYPE} +(marshall-TYPE*) DEFINES (marshall-${TYPE}*) +(marshall-TYPE**) DEFINES (marshall-${TYPE}**) +marshall-TYPE* DEFINES marshall-${TYPE}* +marshall-TYPE** DEFINES marshall-${TYPE}** +marshall-TYPE*-free DEFINES marshall-${TYPE}*-free +marshall-TYPE**-free DEFINES marshall-${TYPE}**-free +unmarshall-TYPE* DEFINES unmarshall-${TYPE}* +unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free +WHERE + malloc-byte-array ] + [ >TYPE-array malloc-underlying ] + marshall-x* ; +PRIVATE> +: marshall-TYPE* ( n/seq -- alien ) + [ (marshall-TYPE*) ] ptr-pass-through ; + +: marshall-TYPE** ( seq -- alien ) + [ (marshall-TYPE**) ] ptr-pass-through ; +: unmarshall-TYPE* ( alien -- n ) + *TYPE ; inline +: unmarshall-TYPE*-free ( alien -- n ) + [ unmarshall-TYPE* ] keep add-malloc free ; +;FUNCTOR + +SYNTAX: PRIMITIVE-MARSHALLERS: +";" parse-tokens [ define-primitive-marshallers ] each ; diff --git a/extra/alien/marshall/structs/authors.txt b/extra/alien/marshall/structs/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/marshall/structs/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/marshall/structs/structs-docs.factor b/extra/alien/marshall/structs/structs-docs.factor new file mode 100644 index 0000000000..0c5645810e --- /dev/null +++ b/extra/alien/marshall/structs/structs-docs.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: classes help.markup help.syntax kernel quotations words +alien.marshall.structs strings alien.structs alien.marshall ; +IN: alien.marshall.structs + +HELP: define-marshalled-struct +{ $values + { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" } +} +{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ; + +HELP: define-struct-tuple +{ $values + { "name" string } +} +{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, " + "and accessor words." +} ; diff --git a/extra/alien/marshall/structs/structs.factor b/extra/alien/marshall/structs/structs.factor new file mode 100644 index 0000000000..54bcab45f2 --- /dev/null +++ b/extra/alien/marshall/structs/structs.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.marshall arrays assocs +classes.tuple combinators destructors generalizations generic +kernel libc locals parser quotations sequences slots words +alien.structs lexer vocabs.parser fry effects ; +IN: alien.marshall.structs + +>" append \ underlying>> ] 2dip + struct-field-unmarshaller \ call 4array >quotation + define-struct-accessor ; + +: define-struct-setter ( class name word type -- ) + [ "(>>" prepend ")" append ] 2dip + marshaller [ underlying>> ] \ bi* roll 4array >quotation + define-struct-accessor ; + +: define-struct-accessors ( class name type reader writer -- ) + [ dup define-protocol-slot ] 3dip + [ drop swap define-struct-getter ] + [ nip swap define-struct-setter ] 5 nbi ; + +: define-struct-constructor ( class -- ) + { + [ name>> "<" prepend ">" append create-in ] + [ '[ _ new ] ] + [ name>> '[ _ malloc-object >>underlying ] append ] + [ name>> 1array ] + } cleave { } swap define-declared ; +PRIVATE> + +:: define-struct-tuple ( name -- ) + name create-in :> class + class struct-wrapper { } define-tuple-class + class define-struct-constructor + name c-type fields>> [ + class swap + { + [ name>> { { CHAR: space CHAR: - } } substitute ] + [ type>> ] [ reader>> ] [ writer>> ] + } cleave define-struct-accessors + ] each ; + +: define-marshalled-struct ( name vocab fields -- ) + [ define-struct ] [ 2drop define-struct-tuple ] 3bi ; diff --git a/extra/alien/marshall/syntax/authors.txt b/extra/alien/marshall/syntax/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/marshall/syntax/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor new file mode 100644 index 0000000000..401934e736 --- /dev/null +++ b/extra/alien/marshall/syntax/syntax-docs.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations words +alien.inline alien.syntax effects alien.marshall +alien.marshall.structs strings sequences alien.inline.syntax ; +IN: alien.marshall.syntax + +HELP: CM-FUNCTION: +{ $syntax "CM-FUNCTION: return name args\n body\n;" } +{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling " + "of arguments and return values." +} +{ $examples + { $example + "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;" + "IN: example" + "" + "C-LIBRARY: exlib" + "" + "C-INCLUDE: " + "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )" + " *x = a + b;" + " *y = a - b;" + " char* s = (char*) malloc(sizeof(char) * 64);" + " sprintf(s, \"sum %i, diff %i\", *x, *y);" + " return s;" + ";" + "" + ";C-LIBRARY" + "" + "8 5 0 0 sum_diff . . ." + "3\n13\n\"sum 13, diff 3\"" + } +} +{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ; + +HELP: CM-STRUCTURE: +{ $syntax "CM-STRUCTURE: name fields ... ;" } +{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. " + "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words." +} +{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ; + +HELP: M-FUNCTION: +{ $syntax "M-FUNCTION: return name args ;" } +{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling " + "of arguments and return values." +} +{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ; + +HELP: M-STRUCTURE: +{ $syntax "M-STRUCTURE: name fields ... ;" } +{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. " + "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words." +} +{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ; + +HELP: define-c-marshalled +{ $values + { "name" string } { "types" sequence } { "effect" effect } { "body" string } +} +{ $description "Defines a C function and a factor word which calls it with marshalling of " + "args and return values." +} +{ $see-also define-c-marshalled' } ; + +HELP: define-c-marshalled' +{ $values + { "name" string } { "effect" effect } { "body" string } +} +{ $description "Like " { $link define-c-marshalled } ". " + "The effect elements must be C type strings." +} ; + +HELP: marshalled-function +{ $values + { "name" string } { "types" sequence } { "effect" effect } + { "word" word } { "quot" quotation } { "effect" effect } +} +{ $description "Defines a word which calls the named C function. Arguments, " + "return value, and output parameters are marshalled and unmarshalled." +} ; + diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor new file mode 100644 index 0000000000..3945924a57 --- /dev/null +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.inline.syntax alien.marshall.syntax destructors +tools.test accessors kernel ; +IN: alien.marshall.syntax.tests + +DELETE-C-LIBRARY: test +C-LIBRARY: test + +C-INCLUDE: +C-INCLUDE: + +C-TYPEDEF: char bool + +CM-FUNCTION: void outarg1 ( int* a ) + *a += 2; +; + +CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) + unsigned long* x = malloc(sizeof(unsigned long*)); + *b = 10 + *b; + *x = a + *b; + return x; +; + +CM-STRUCTURE: wedge + { "double" "degrees" } ; + +CM-STRUCTURE: sundial + { "double" "radius" } + { "wedge" "wedge" } ; + +CM-FUNCTION: double hours ( sundial* d ) + return d->wedge.degrees / 30; +; + +CM-FUNCTION: void change_time ( double hours, sundial* d ) + d->wedge.degrees = hours * 30; +; + +CM-FUNCTION: bool c_not ( bool p ) + return !p; +; + +CM-FUNCTION: char* upcase ( const-char* s ) + int len = strlen(s); + char* t = malloc(sizeof(char) * len); + int i; + for (i = 0; i < len; i++) + t[i] = toupper(s[i]); + t[i] = '\0'; + return t; +; + +;C-LIBRARY + +{ 1 1 } [ outarg1 ] must-infer-as +[ 3 ] [ 1 outarg1 ] unit-test +[ 3 ] [ t outarg1 ] unit-test +[ 2 ] [ f outarg1 ] unit-test + +{ 2 2 } [ outarg2 ] must-infer-as +[ 18 15 ] [ 3 5 outarg2 ] unit-test + +{ 1 1 } [ hours ] must-infer-as +[ 5.0 ] [ 150 >>degrees >>wedge hours ] unit-test + +{ 2 0 } [ change_time ] must-infer-as +[ 150.0 ] [ 5 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test + +{ 1 1 } [ c_not ] must-infer-as +[ f ] [ "x" c_not ] unit-test +[ f ] [ 0 c_not ] unit-test + +{ 1 1 } [ upcase ] must-infer-as +[ "ABC" ] [ "abc" upcase ] unit-test diff --git a/extra/alien/marshall/syntax/syntax.factor b/extra/alien/marshall/syntax/syntax.factor new file mode 100644 index 0000000000..334343654c --- /dev/null +++ b/extra/alien/marshall/syntax/syntax.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.inline alien.inline.types alien.marshall +combinators effects generalizations kernel locals make namespaces +quotations sequences words alien.marshall.structs lexer parser +vocabs.parser multiline ; +IN: alien.marshall.syntax + +:: marshalled-function ( name types effect -- word quot effect ) + name types effect factor-function + [ in>> ] + [ out>> types [ pointer-to-non-const-primitive? ] filter append ] + bi + [ + [ + types [ marshaller ] map , \ spread , , + types length , \ nkeep , + types [ out-arg-unmarshaller ] map + effect out>> dup empty? + [ drop ] [ first unmarshaller prefix ] if + , \ spread , + ] [ ] make + ] dip ; + +: define-c-marshalled ( name types effect body -- ) + [ + [ marshalled-function define-declared ] + [ prototype-string ] 3bi + ] dip append-function-body c-strings get push ; + +: define-c-marshalled' ( name effect body -- ) + [ + [ in>> ] keep + [ marshalled-function define-declared ] + [ out>> prototype-string' ] 3bi + ] dip append-function-body c-strings get push ; + +SYNTAX: CM-FUNCTION: + function-types-effect parse-here define-c-marshalled ; + +SYNTAX: M-FUNCTION: + function-types-effect marshalled-function define-declared ; + +SYNTAX: M-STRUCTURE: + scan current-vocab parse-definition + define-marshalled-struct ; + +SYNTAX: CM-STRUCTURE: + scan current-vocab parse-definition + [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index ca71e22e9f..23809f2744 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger math namespaces memory ; +continuations debugger math namespaces memory fry ; IN: benchmark +: (run-benchmark) ( vocab -- time ) + [ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ; + : run-benchmark ( vocab -- ) [ "=== " write print flush ] [ - [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ] + [ [ require ] [ (run-benchmark) ] [ ] tri timings ] [ swap errors ] recover get set-at ] bi ; @@ -24,6 +27,7 @@ PRIVATE> V{ } clone timings set V{ } clone errors set "benchmark" child-vocab-names + [ find-vocab-root ] filter [ run-benchmark ] each timings get errors get