--- /dev/null
+Jeremy Hughes
--- /dev/null
+Jeremy Hughes
--- /dev/null
+! 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 ;
+
+: compiler ( lang -- str )
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+: link-command ( in out lang -- descr )
+ compiler os {
+ { [ dup linux? ]
+ [ drop { "-shared" "-o" } ] }
+ { [ dup macosx? ]
+ [ drop { "-g" "-prebind" "-dynamiclib" "-o" } ] }
+ [ name>> "unimplemented for: " prepend throw ]
+ } cond swap prefix prepend prepend ;
+
+:: 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
+ { "-fPIC" "-c" "-o" } lang compiler prefix prepend
+ try-process ;
+
+:: link-object ( lang args name -- )
+ args name [ "lib" prepend library-suffix append ]
+ [ ".o" append ] bi [ temp-file ] bi@ 2array
+ lang link-command try-process ;
+
+:: compile-to-library ( lang args contents name -- )
+ lang contents name compile-to-object
+ lang args name link-object ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.files io.files.info io.files.temp
+kernel lexer math math.order math.ranges multiline namespaces
+sequences splitting strings system vocabs.loader
+vocabs.parser words ;
+IN: alien.inline
+
+<PRIVATE
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: compiler-args
+SYMBOL: c-strings
+
+: function-types-effect ( -- function types effect )
+ scan scan swap ")" parse-tokens
+ [ "(" subseq? not ] filter swap parse-arglist ;
+
+: arg-list ( types -- params )
+ CHAR: a swap length CHAR: a + [a,b]
+ [ 1string ] map ;
+
+: 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 ;
+
+: 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 ] <effect> prototype-string ;
+
+: append-function-body ( prototype-str -- str )
+ " {\n" append parse-here append "\n}\n" append ;
+
+
+: 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 ;
+PRIVATE>
+
+: define-c-library ( name -- )
+ c-library set
+ V{ } clone c-strings set
+ V{ } clone compiler-args set ;
+
+: compile-c-library ( -- )
+ compile-library? [ compile-library ] when
+ c-library get library-path "cdecl" add-library ;
+
+: define-c-function ( function types effect -- )
+ [ factor-function define-declared ] 3keep prototype-string
+ append-function-body c-strings get push ;
+
+: define-c-function' ( function effect -- )
+ [ in>> ] keep [ factor-function define-declared ] 3keep
+ out>> prototype-string'
+ append-function-body c-strings get push ;
+
+: define-c-link ( str -- )
+ "-l" prepend compiler-args get push ;
+
+: define-c-framework ( str -- )
+ "-framework" swap compiler-args get '[ _ push ] bi@ ;
+
+: define-c-link/framework ( str -- )
+ os macosx? [ define-c-framework ] [ define-c-link ] if ;
+
+: define-c-include ( str -- )
+ "#include " prepend c-strings get push ;
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan define-c-link ;
+
+SYNTAX: C-FRAMEWORK: scan define-c-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
+
+SYNTAX: C-INCLUDE: scan define-c-include ;
+
+SYNTAX: C-FUNCTION:
+ function-types-effect define-c-function ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;
--- /dev/null
+! 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;
+;
+
+<< [ compile-c-library ] must-fail >>
+
+<< library-path dup exists? [ delete-file ] [ drop ] if >>
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+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? ;
+
+MEMO: resolved-primitives ( -- seq )
+ primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+ [
+ factorize-type resolve-typedef [ resolved-primitives ] dip
+ '[ _ = ] any?
+ ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+ [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+ [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+ { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+ [ in>> zip ]
+ [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+ 2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+ [ in>> ] [ out>> ] bi [
+ zip
+ [ over pointer-to-primitive? [ ">" prepend ] when ]
+ assoc-map unzip
+ ] dip <effect> ;
}
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
+"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
+"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: bit-sets.tests
+USING: bit-sets tools.test bit-arrays ;
+
+[ ?{ t f t f t f } ] [
+ ?{ t f f f t f }
+ ?{ f f t f t f } bit-set-union
+] unit-test
+
+[ ?{ f f f f t f } ] [
+ ?{ t f f f t f }
+ ?{ f f t f t f } bit-set-intersect
+] unit-test
+
+[ ?{ t f t f f f } ] [
+ ?{ t t t f f f }
+ ?{ f t f f t t } bit-set-diff
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+IN: bit-sets
+
+<PRIVATE
+
+: bit-set-map ( seq1 seq2 quot -- seq )
+ [ 2drop length>> ]
+ [
+ [
+ [ [ length ] bi@ assert= ]
+ [ [ underlying>> ] bi@ ] 2bi
+ ] dip 2map
+ ] 3bi bit-array boa ; inline
+
+PRIVATE>
+
+: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+
+HINTS: bit-set-union bit-array bit-array ;
+
+: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+
+HINTS: bit-set-intersect bit-array bit-array ;
+
+: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+
+HINTS: bit-set-diff bit-array bit-array ;
\ No newline at end of file
--- /dev/null
+Efficient bitwise operations on bit arrays
--- /dev/null
+IN: compiler.cfg.branch-folding.tests
+USING: compiler.cfg.branch-folding compiler.cfg.instructions
+compiler.cfg compiler.cfg.registers compiler.cfg.debugger
+arrays compiler.cfg.phi-elimination compiler.cfg.dce
+compiler.cfg.predecessors kernel accessors assocs
+sequences classes namespaces tools.test cpu.architecture ;
+
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 { } }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test
+
+[ 1 ] [ 1 get successors>> length ] unit-test
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ 2 ] [ 4 get instructions>> length ] unit-test
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+ T{ ##copy f V int-regs 2 V int-regs 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 V{ } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+ cfg new 0 get >>entry
+ compute-predecessors
+ fold-branches
+ compute-predecessors
+ eliminate-dead-code
+ drop
+] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel sequences vectors
+compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.branch-folding
+
+! Fold comparisons where both inputs are the same. Predecessors must be
+! recomputed after this
+
+: fold-branch? ( bb -- ? )
+ instructions>> last {
+ [ ##compare-branch? ]
+ [ [ src1>> ] [ src2>> ] bi = ]
+ } 1&& ;
+
+: chosen-successor ( bb -- succ )
+ [ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
+ [ successors>> ]
+ bi nth ;
+
+: fold-branch ( bb -- )
+ dup chosen-successor 1vector >>successors
+ instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: fold-branches ( cfg -- cfg' )
+ dup [
+ dup fold-branch?
+ [ fold-branch ] [ drop ] if
+ ] each-basic-block
+ f >>post-order ;
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math sequences
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
+IN: compiler.cfg.branch-splitting
+
+! Predecessors must be recomputed after this
+
+: split-branch-for ( bb predecessor -- )
+ [
+ [
+ <basic-block>
+ swap
+ [ instructions>> [ clone ] map >>instructions ]
+ [ successors>> clone >>successors ]
+ bi
+ ] keep
+ ] dip
+ [ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
+ drop ;
+
+: split-branch ( bb -- )
+ dup predecessors>> [ split-branch-for ] with each ;
+
+: split-branches? ( bb -- ? )
+ {
+ [ successors>> empty? ]
+ [ predecessors>> length 1 > ]
+ [ instructions>> [ defs-vregs ] any? not ]
+ [ instructions>> [ temp-vregs ] any? not ]
+ } 1&& ;
+
+: split-branches ( cfg -- cfg' )
+ dup [
+ dup split-branches? [ split-branch ] [ drop ] if
+ ] each-basic-block
+ f >>post-order ;
[ 3 fixnum+fast ]
[ fixnum*fast ]
[ 3 fixnum*fast ]
+ [ 3 swap fixnum*fast ]
[ fixnum-shift-fast ]
[ 10 fixnum-shift-fast ]
[ -10 fixnum-shift-fast ]
[ 0 fixnum-shift-fast ]
+ [ 10 swap fixnum-shift-fast ]
+ [ -10 swap fixnum-shift-fast ]
+ [ 0 swap fixnum-shift-fast ]
[ fixnum-bitnot ]
[ eq? ]
[ "hi" eq? ]
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
-compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
-SYMBOL: first-basic-block
-
-! Basic block after prologue, makes recursion faster
-SYMBOL: current-label-start
: add-procedure ( -- )
basic-block get current-word get current-label get
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
-GENERIC: emit-node ( node -- next )
+GENERIC: emit-node ( node -- )
: check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- )
- [ current-node emit-node check-basic-block ] iterate-nodes ;
+ [ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
- #! We store the basic block after the prologue as a loop
- #! labeled by the current word, so that self-recursive
- #! calls can skip an epilogue/prologue.
##prologue
##branch
- begin-basic-block
- basic-block get first-basic-block set ;
+ begin-basic-block ;
: (build-cfg) ( nodes word label -- )
[
begin-word
- V{ } clone node-stack set
emit-nodes
] with-cfg-builder ;
] with-variable
] keep ;
-: local-recursive-call ( basic-block -- next )
+: emit-loop-call ( basic-block -- )
##branch
basic-block get successors>> push
- stop-iterating ;
+ basic-block off ;
-: emit-call ( word height -- next )
- {
- { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
- { [ terminate-call? ] [ ##call stop-iterating ] }
- { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
- { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
- [ drop ##epilogue ##jump stop-iterating ]
- } cond ;
+: emit-call ( word -- )
+ dup loops get key?
+ [ loops get at emit-loop-call ]
+ [ ##call ##branch begin-basic-block ]
+ if ;
! #recursive
-: recursive-height ( #recursive -- n )
- [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
-
-: emit-recursive ( #recursive -- next )
- [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
+: emit-recursive ( #recursive -- )
+ [ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
-: emit-loop ( node -- next )
+: emit-loop ( node -- )
##loop-entry
##branch
begin-basic-block
- [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
- iterate-next ;
+ [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
M: #recursive emit-node
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
] with-scope ;
: emit-if ( node -- )
- children>> [ emit-branch ] map
+ children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
- } cond iterate-next ;
+ } cond ;
! #dispatch
M: #dispatch emit-node
- ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
+ ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
- [ emit-intrinsic ] [ swap call-height emit-call ] if ;
+ [ emit-intrinsic ] [ nip emit-call ] if ;
! #call-recursive
-M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
+M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
- literal>> ^^load-literal ds-push iterate-next ;
+ literal>> ^^load-literal ds-push ;
! #shuffle
M: #shuffle emit-node
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
- [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
- iterate-next ;
+ [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
! #return
M: #return emit-node
- drop ##epilogue ##return stop-iterating ;
+ drop ##epilogue ##return ;
M: #return-recursive emit-node
label>> id>> loops get key?
- [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+ [ ##epilogue ##return ] unless ;
! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node drop ##no-tco basic-block off ;
! FFI
: return-size ( ctype -- n )
: alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ;
-: emit-alien-node ( node quot -- next )
+: emit-alien-node ( node quot -- )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
- ##branch begin-basic-block iterate-next ; inline
+ ##branch begin-basic-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
dup params>> xt>> dup
[
##prologue
- dup [ ##alien-callback ] emit-alien-node drop
+ dup [ ##alien-callback ] emit-alien-node
##epilogue
params>> ##callback-return
- ] with-cfg-builder
- iterate-next ;
+ ] with-cfg-builder ;
! No-op nodes
-M: #introduce emit-node drop iterate-next ;
+M: #introduce emit-node drop ;
-M: #copy emit-node drop iterate-next ;
+M: #copy emit-node drop ;
-M: #enter-recursive emit-node drop iterate-next ;
+M: #enter-recursive emit-node drop ;
-M: #phi emit-node drop iterate-next ;
+M: #phi emit-node drop ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors
-namespaces math make fry sequences ;
+USING: kernel arrays vectors accessors assocs sets
+namespaces math make fry sequences
+combinators.short-circuit
+compiler.cfg.instructions ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
V{ } clone >>predecessors
\ basic-block counter >>id ;
+: empty-block? ( bb -- ? )
+ instructions>> {
+ [ length 1 = ]
+ [ first ##branch? ]
+ } 1&& ;
+
+SYMBOL: visited
+
+: (skip-empty-blocks) ( bb -- bb' )
+ dup visited get key? [
+ dup empty-block? [
+ dup visited get conjoin
+ successors>> first (skip-empty-blocks)
+ ] when
+ ] unless ;
+
+: skip-empty-blocks ( bb -- bb' )
+ H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
+
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
- [ ##call? ]
+ [ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry ;
-Slava Pestov
\ No newline at end of file
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test compiler.cfg kernel accessors compiler.cfg.dce
+compiler.cfg.instructions compiler.cfg.registers cpu.architecture ;
+IN: compiler.cfg.dce.tests
+
+: test-dce ( insns -- insns' )
+ <basic-block> swap >>instructions
+ cfg new swap >>entry
+ eliminate-dead-code
+ entry>> instructions>> ;
+
+[ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} ] [ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} ] [ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
+: live-vreg? ( vreg -- ? )
+ live-vregs get key? ;
+
+! vregs which are the result of an allocation
+SYMBOL: allocations
+
+: allocation? ( vreg -- ? )
+ allocations get key? ;
+
: init-dead-code ( -- )
H{ } clone liveness-graph set
- H{ } clone live-vregs set ;
+ H{ } clone live-vregs set
+ H{ } clone allocations set ;
+
+GENERIC: build-liveness-graph ( insn -- )
+
+: add-edges ( insn register -- )
+ [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
+
+: setter-liveness-graph ( insn vreg -- )
+ dup allocation? [ add-edges ] [ 2drop ] if ;
+
+M: ##set-slot build-liveness-graph
+ dup obj>> setter-liveness-graph ;
+
+M: ##set-slot-imm build-liveness-graph
+ dup obj>> setter-liveness-graph ;
+
+M: ##write-barrier build-liveness-graph
+ dup src>> setter-liveness-graph ;
+
+M: ##flushable build-liveness-graph
+ dup dst>> add-edges ;
-GENERIC: update-liveness-graph ( insn -- )
+M: ##allot build-liveness-graph
+ [ dst>> allocations get conjoin ]
+ [ call-next-method ] bi ;
-M: ##flushable update-liveness-graph
- [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+M: insn build-liveness-graph drop ;
-: record-live ( vregs -- )
+GENERIC: compute-live-vregs ( insn -- )
+
+: (record-live) ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
- [ liveness-graph get at record-live ]
+ [ liveness-graph get at (record-live) ]
bi
] if
] each ;
-M: insn update-liveness-graph uses-vregs record-live ;
+: record-live ( insn -- )
+ uses-vregs (record-live) ;
+
+: setter-live-vregs ( insn vreg -- )
+ allocation? [ drop ] [ record-live ] if ;
+
+M: ##set-slot compute-live-vregs
+ dup obj>> setter-live-vregs ;
+
+M: ##set-slot-imm compute-live-vregs
+ dup obj>> setter-live-vregs ;
+
+M: ##write-barrier compute-live-vregs
+ dup src>> setter-live-vregs ;
+
+M: ##flushable compute-live-vregs drop ;
+
+M: insn compute-live-vregs
+ record-live ;
GENERIC: live-insn? ( insn -- ? )
-M: ##flushable live-insn? dst>> live-vregs get key? ;
+M: ##flushable live-insn? dst>> live-vreg? ;
+
+M: ##set-slot live-insn? obj>> live-vreg? ;
+
+M: ##set-slot-imm live-insn? obj>> live-vreg? ;
+
+M: ##write-barrier live-insn? src>> live-vreg? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
init-dead-code
- [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
- [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
- [ ]
- tri ;
\ No newline at end of file
+ dup
+ [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
+ [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
+ [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ]
+ tri ;
--- /dev/null
+Dead code elimination
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel compiler.cfg.instructions ;
+USING: accessors arrays kernel assocs compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##phi uses-vregs inputs>> ;
+M: ##phi uses-vregs inputs>> values ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs
-cpu.architecture compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.instructions
+compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.hats ;
IN: compiler.cfg.gc-checks
: gc? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
-: object-pointer-regs ( basic-block -- vregs )
- live-in keys [ reg-class>> int-regs eq? ] filter ;
-
: insert-gc-check ( basic-block -- )
dup gc? [
- [ i i f f \ ##gc new-insn prefix ] change-instructions drop
+ [ i i f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ;
: insert-gc-checks ( cfg -- cfg' )
! Subroutine calls
INSN: ##stack-frame stack-frame ;
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
+! Dummy instruction that simply inhibits TCO
+INSN: ##no-tco ;
+
! Jump tables
INSN: ##dispatch src temp ;
{ cc/= cc= }
} at ;
+: swap-cc ( cc -- cc' )
+ H{
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc/= cc/= }
+ } at ;
+
: evaluate-cc ( result cc -- ? )
H{
{ cc< { +lt+ } }
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
-INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
-SYMBOL: temp-spill
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
-compiler.cfg.iterator
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.registers ;
0 cc= ^^compare-imm
ds-push ;
-: (emit-fixnum-imm-op) ( infos insn -- dst )
- ds-drop
- [ ds-pop ]
- [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
- [ ]
- tri*
- call ; inline
+: tag-literal ( n -- tagged )
+ literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+: emit-fixnum-imm-op1 ( infos insn -- dst )
+ [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
+
+: emit-fixnum-imm-op2 ( infos insn -- dst )
+ [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
: (emit-fixnum-op) ( insn -- dst )
[ 2inputs ] dip call ; inline
:: emit-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos second value-info-small-tagged?
- [ infos imm-insn (emit-fixnum-imm-op) ]
- [ insn (emit-fixnum-op) ]
- if
+ [ infos imm-insn emit-fixnum-imm-op2 ]
+ [ insn (emit-fixnum-op) ] if
+ ds-push
+ ] ; inline
+
+:: emit-commutative-fixnum-op ( node insn imm-insn -- )
+ [let | infos [ node node-input-infos ] |
+ {
+ { [ infos first value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op1 ] }
+ { [ infos second value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op2 ] }
+ [ insn (emit-fixnum-op) ]
+ } cond
ds-push
] ; inline
} case
ds-push
] [ drop emit-primitive ] if ;
-
+
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
-: (emit-fixnum*fast-imm) ( infos -- dst )
- ds-drop
- [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
+: (emit-fixnum*fast-imm1) ( infos -- dst )
+ [ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
+
+: (emit-fixnum*fast-imm2) ( infos -- dst )
+ [ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: emit-fixnum*fast ( node -- )
node-input-infos
- dup second value-info-small-fixnum?
- [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+ dup first value-info-small-fixnum? drop f
+ [
+ (emit-fixnum*fast-imm1)
+ ] [
+ dup second value-info-small-fixnum?
+ [ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
+ ] if
ds-push ;
+: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
+ [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
+
+: emit-eq ( node -- )
+ cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
+
: emit-fixnum-comparison ( node cc -- )
- [ ^^compare ] [ ^^compare-imm ] bi-curry
- emit-fixnum-op ;
+ (emit-fixnum-comparison) emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
-: emit-fixnum-overflow-op ( quot quot-tail -- next )
- [ 2inputs 1 ##inc-d ] 2dip
- tail-call? [
- ##epilogue
- nip call
- stop-iterating
- ] [
- drop call
- ##branch
- begin-basic-block
- iterate-next
- ] if ; inline
+: emit-fixnum-overflow-op ( quot -- next )
+ [ 2inputs 1 ##inc-d ] dip call ##branch
+ begin-basic-block ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
-compiler.cfg.intrinsics.misc
-compiler.cfg.iterator ;
+compiler.cfg.intrinsics.misc ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
-: emit-intrinsic ( node word -- node/f )
+: emit-intrinsic ( node word -- )
{
- { \ kernel.private:tag [ drop emit-tag iterate-next ] }
- { \ kernel.private:getenv [ emit-getenv iterate-next ] }
- { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
- { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
- { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
- { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
- { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
- { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
- { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
- { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
- { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
- { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
- { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
- { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
- { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
- { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
- { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
- { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
- { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
- { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
- { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
- { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
- { \ slots.private:slot [ emit-slot iterate-next ] }
- { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
- { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
- { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
- { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
- { \ arrays:<array> [ emit-<array> iterate-next ] }
- { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
- { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
- { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
- { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
- { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
- { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
- { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
- { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
- { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
+ { \ kernel.private:tag [ drop emit-tag ] }
+ { \ kernel.private:getenv [ emit-getenv ] }
+ { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
+ { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+ { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+ { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+ { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+ { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+ { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+ { \ kernel:eq? [ emit-eq ] }
+ { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+ { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+ { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+ { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+ { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+ { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { \ math.private:float< [ drop cc< emit-float-comparison ] }
+ { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+ { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+ { \ math.private:float> [ drop cc> emit-float-comparison ] }
+ { \ math.private:float= [ drop cc= emit-float-comparison ] }
+ { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+ { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { \ slots.private:slot [ emit-slot ] }
+ { \ slots.private:set-slot [ emit-set-slot ] }
+ { \ strings.private:string-nth [ drop emit-string-nth ] }
+ { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
+ { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+ { \ arrays:<array> [ emit-<array> ] }
+ { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+ { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
+ { \ kernel:<wrapper> [ emit-simple-allot ] }
+ { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+ { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+ { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+ { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.cfg.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get last ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
- over empty? [
- 2drop
- ] [
- [ swap >node call node> drop ] keep iterate-nodes
- ] if ; inline recursive
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
- [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
- [ t ] [
- [
- first
- [ #return? ]
- [ #return-recursive? ]
- [ #terminate? ] tri or or
- ] [ tail-phi? ] bi or
- ] if-empty ;
-
-: tail-call? ( -- ? )
- node-stack get [
- rest-slice
- [ t ] [ (tail-call?) ] if-empty
- ] all? ;
-
-: terminate-call? ( -- ? )
- node-stack get last
- rest-slice [ f ] [ first #terminate? ] if-empty ;
+++ /dev/null
-Utility for iterating for high-level IR
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
-combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
-: free-positions ( new -- assoc )
- vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+: active-positions ( new assoc -- )
+ [ vreg>> active-intervals-for ] dip
+ '[ [ 0 ] dip reg>> _ add-use-position ] each ;
-: active-positions ( new -- assoc )
- vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
+: inactive-positions ( new assoc -- )
+ [ [ vreg>> inactive-intervals-for ] keep ] dip
+ '[
+ [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
+ _ add-use-position
+ ] each ;
-: inactive-positions ( new -- assoc )
- dup vreg>> inactive-intervals-for
- [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
- with H{ } map>assoc ;
-
-: compute-free-pos ( new -- free-pos )
- [ free-positions ] [ inactive-positions ] [ active-positions ] tri
- 3array assoc-combine >alist alist-max ;
+: register-status ( new -- free-pos )
+ dup free-positions
+ [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+ >alist alist-max ;
: no-free-registers? ( result -- ? )
second 0 = ; inline
-: register-available? ( new result -- ? )
- [ end>> ] [ second ] bi* < ; inline
-
-: register-available ( new result -- )
- first >>reg add-active ;
-
: register-partially-available ( new result -- )
[ second split-before-use ] keep
'[ _ register-available ] [ add-unhandled ] bi* ;
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
- dup compute-free-pos {
+ dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
[ register-partially-available ]
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-: intersects-inactive-intervals? ( live-interval -- ? )
+: avoids-inactive-intervals? ( live-interval -- ? )
dup vreg>> inactive-intervals-for
- [ relevant-ranges intersect-live-ranges 1/0. = ] with all? ;
+ [ intervals-intersect? not ] with all? ;
: coalesce? ( live-interval -- ? )
{
[ copy-from>> active-interval ]
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
- [ intersects-inactive-intervals? ]
+ [ avoids-inactive-intervals? ]
} 1&& ;
: coalesce ( live-interval -- )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting compiler.utilities
+math sequences sets sorting splitting namespaces
+combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling
-: find-use ( live-interval n quot -- elt )
- [ uses>> ] 2dip curry find nip ; inline
+ERROR: bad-live-ranges interval ;
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
+: check-ranges ( live-interval -- )
+ check-allocation? get [
+ dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
+ [ drop ] [ bad-live-ranges ] if
+ ] [ drop ] if ;
-: interval-to-spill ( active-intervals current -- live-interval )
- #! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use ] { } map>assoc
- alist-max first ;
+: trim-before-ranges ( live-interval -- )
+ [ ranges>> ] [ uses>> last ] bi
+ [ '[ from>> _ <= ] filter-here ]
+ [ swap last (>>to) ]
+ 2bi ;
+
+: trim-after-ranges ( live-interval -- )
+ [ ranges>> ] [ uses>> first ] bi
+ [ '[ to>> _ >= ] filter-here ]
+ [ swap first (>>from) ]
+ 2bi ;
: split-for-spill ( live-interval n -- before after )
split-interval
+ {
+ [ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
+ [ [ compute-start/end ] bi@ ]
+ [ [ check-ranges ] bi@ ]
+ [ ]
+ } 2cleave ;
+
+: assign-spill ( live-interval -- )
+ dup vreg>> assign-spill-slot >>spill-to drop ;
+
+: assign-reload ( live-interval -- )
+ dup vreg>> assign-spill-slot >>reload-from drop ;
+
+: split-and-spill ( live-interval n -- before after )
+ split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
+
+: find-use-position ( live-interval new -- n )
+ [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+
+: find-use-positions ( live-intervals new assoc -- )
+ '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
+
+: active-positions ( new assoc -- )
+ [ [ vreg>> active-intervals-for ] keep ] dip
+ find-use-positions ;
+
+: inactive-positions ( new assoc -- )
[
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
- ]
- [ [ compute-start/end ] bi@ ]
- [ ]
- 2tri ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>>
- [ over vreg>> reg-class>> next-spill-location ] unless*
- [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
-
-: split-and-spill ( new existing -- before after )
- swap start>> split-for-spill assign-spill ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ nip delete-active ]
- [ reg>> >>reg add-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ dup split-and-spill add-unhandled ] dip spill-existing ;
+ [ vreg>> inactive-intervals-for ] keep
+ [ '[ _ intervals-intersect? ] filter ] keep
+ ] dip
+ find-use-positions ;
-: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+: spill-status ( new -- use-pos )
+ H{ } clone
+ [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+ >alist alist-max ;
+
+: spill-new? ( new pair -- ? )
+ [ uses>> first ] [ second ] bi* > ;
+
+: spill-new ( new pair -- )
+ drop
+ {
+ [ trim-after-ranges ]
+ [ compute-start/end ]
+ [ assign-reload ]
+ [ add-unhandled ]
+ } cleave ;
+
+: split-intersecting? ( live-interval new reg -- ? )
+ { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
+: split-live-out ( live-interval -- )
+ {
+ [ trim-before-ranges ]
+ [ compute-start/end ]
+ [ assign-spill ]
+ [ add-handled ]
+ } cleave ;
+
+: split-live-in ( live-interval -- )
+ {
+ [ trim-after-ranges ]
+ [ compute-start/end ]
+ [ assign-reload ]
+ [ add-unhandled ]
+ } cleave ;
+
+: (split-intersecting) ( live-interval new -- )
+ start>> {
+ { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] }
+ { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] }
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
+ } cond ;
+
+: (split-intersecting-active) ( active new -- )
+ [ drop delete-active ]
+ [ (split-intersecting) ] 2bi ;
+
+: split-intersecting-active ( new reg -- )
+ [ [ vreg>> active-intervals-for ] keep ] dip
+ [ '[ _ _ split-intersecting? ] filter ] 2keep drop
+ '[ _ (split-intersecting-active) ] each ;
+
+: (split-intersecting-inactive) ( inactive new -- )
+ [ drop delete-inactive ]
+ [ (split-intersecting) ] 2bi ;
+
+: split-intersecting-inactive ( new reg -- )
+ [ [ vreg>> inactive-intervals-for ] keep ] dip
+ [ '[ _ _ split-intersecting? ] filter ] 2keep drop
+ '[ _ (split-intersecting-inactive) ] each ;
+
+: split-intersecting ( new reg -- )
+ [ split-intersecting-active ]
+ [ split-intersecting-inactive ]
+ 2bi ;
+
+: spill-available ( new pair -- )
+ [ first split-intersecting ] [ register-available ] 2bi ;
+
+: spill-partially-available ( new pair -- )
+ [ second 1 - split-and-spill add-unhandled ] keep
+ spill-available ;
+
+: assign-blocked-register ( new -- )
+ dup spill-status {
+ { [ 2dup spill-new? ] [ spill-new ] }
+ { [ 2dup register-available? ] [ spill-available ] }
+ [ spill-partially-available ]
+ } cond ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting
+math sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting
ERROR: splitting-too-early ;
+ERROR: splitting-too-late ;
+
ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- )
- [ [ start>> ] dip > [ splitting-too-early ] when ]
- [ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
- 2bi ; inline
+ check-allocation? get [
+ [ [ start>> ] dip > [ splitting-too-early ] when ]
+ [ [ end>> ] dip <= [ splitting-too-late ] when ]
+ [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
+ 2tri
+ ] [ 2drop ] if ; inline
: split-before ( before -- before' )
f >>spill-to ; inline
2dup [ compute-start/end ] bi@ ;
: insert-use-for-copy ( seq n -- seq' )
- dup 1 + [ nip 1array split1 ] 2keep 2array glue ;
+ [ '[ _ < ] filter ]
+ [ nip dup 1 + 2array ]
+ [ 1 + '[ _ > ] filter ]
+ 2tri 3append ;
: split-before-use ( new n -- before after )
- ! Find optimal split position
- ! Insert move instruction
1 -
2dup swap covers? [
[ '[ _ insert-use-for-copy ] change-uses ] keep
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
-kernel math namespaces sequences vectors
+kernel math math.order namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than this one. This ensures that we can catch
+! infinite loop situations. We also ensure that all live
+! intervals added to the handled set have an end index strictly
+! smaller than this one. This helps catch bugs.
+SYMBOL: progress
+
+: check-unhandled ( live-interval -- )
+ start>> progress get <= [ "check-unhandled" throw ] when ; inline
+
+: check-handled ( live-interval -- )
+ end>> progress get > [ "check-handled" throw ] when ; inline
+
! Mapping from register classes to sequences of machine registers
SYMBOL: registers
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
+: delete-inactive ( live-interval -- )
+ dup vreg>> inactive-intervals-for delq ;
+
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
- handled-intervals get push ;
+ [ check-handled ] [ handled-intervals get push ] bi ;
: finished? ( n live-interval -- ? ) end>> swap < ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
: add-unhandled ( live-interval -- )
- [ check-progress ]
+ [ check-unhandled ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
+! Mapping from register classes to spill counts
SYMBOL: spill-counts
-: next-spill-location ( reg-class -- n )
+: next-spill-slot ( reg-class -- n )
spill-counts get [ dup 1 + ] change-at ;
+! Mapping from vregs to spill slots
+SYMBOL: spill-slots
+
+: assign-spill-slot ( vreg -- n )
+ spill-slots get [ reg-class>> next-spill-slot ] cache ;
+
: init-allocator ( registers -- )
registers set
- [ 0 ] reg-class-assoc spill-counts set
<min-heap> unhandled-intervals set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
+ [ 0 ] reg-class-assoc spill-counts set
+ H{ } clone spill-slots set
-1 progress set ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
\ No newline at end of file
+ unhandled-intervals get heap-push-all ;
+
+! A utility used by register-status and spill-status words
+: free-positions ( new -- assoc )
+ vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+
+: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
+
+: register-available? ( new result -- ? )
+ [ end>> ] [ second ] bi* < ; inline
+
+: register-available ( new result -- )
+ first >>reg add-active ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets
+fry make combinators sets locals
cpu.architecture
+compiler.cfg
compiler.cfg.def-use
+compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
-! Mapping spill slots to vregs
-SYMBOL: spill-slots
+! Mapping from basic blocks to values which are live at the start
+SYMBOL: register-live-ins
-: spill-slots-for ( vreg -- assoc )
- reg-class>> spill-slots get at ;
+! Mapping from basic blocks to values which are live at the end
+SYMBOL: register-live-outs
-ERROR: already-spilled ;
-
-: record-spill ( live-interval -- )
- [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ already-spilled ] [ set-at ] if ;
+: init-assignment ( live-intervals -- )
+ V{ } clone pending-intervals set
+ <min-heap> unhandled-intervals set
+ H{ } clone register-live-ins set
+ H{ } clone register-live-outs set
+ init-unhandled ;
: insert-spill ( live-interval -- )
{
} cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- )
- dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+ dup spill-to>> [ insert-spill ] [ drop ] if ;
+
+: first-split ( live-interval -- live-interval' )
+ dup split-before>> [ first-split ] [ ] ?if ;
+
+: next-interval ( live-interval -- live-interval' )
+ split-next>> first-split ;
: insert-copy ( live-interval -- )
{
- [ split-next>> reg>> ]
+ [ next-interval reg>> ]
[ reg>> ]
[ vreg>> reg-class>> ]
[ end>> ]
} cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- )
- dup [ spill-to>> not ] [ split-next>> ] bi and
- [ insert-copy ] [ drop ] if ;
+ dup split-next>> [ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ;
-ERROR: already-reloaded ;
-
-: record-reload ( live-interval -- )
- [ reload-from>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ delete-at ] [ already-reloaded ] if ;
-
: insert-reload ( live-interval -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ reload-from>> ]
- [ end>> ]
+ [ start>> ]
} cleave f swap \ _reload boa , ;
: handle-reload ( live-interval -- )
- dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
+ dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction
] [ 2drop ] if
] if ;
+: prepare-insn ( n -- )
+ [ expire-old-intervals ] [ activate-new-intervals ] bi ;
+
GENERIC: assign-registers-in-insn ( insn -- )
: register-mapping ( live-intervals -- alist )
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+ [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-: active-intervals ( insn -- intervals )
- insn#>> pending-intervals get [ covers? ] with filter ;
+SYMBOL: check-assignment?
+
+ERROR: overlapping-registers intervals ;
+
+: check-assignment ( intervals -- )
+ dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
+ dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
+
+: active-intervals ( n -- intervals )
+ pending-intervals get [ covers? ] with filter
+ check-assignment? get [ dup check-assignment ] when ;
M: vreg-insn assign-registers-in-insn
- dup [ active-intervals ] [ all-vregs ] bi
- '[ vreg>> _ member? ] filter
+ dup [ all-vregs ] [ insn#>> active-intervals ] bi
+ '[ _ [ vreg>> = ] with find nip ] map
register-mapping
>>regs drop ;
-: compute-live-registers ( insn -- regs )
- [ active-intervals ] [ temp-vregs ] bi
- '[ vreg>> _ memq? not ] filter
- register-mapping ;
-
-: compute-live-spill-slots ( -- spill-slots )
- spill-slots get values [ values ] map concat
- [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
-
M: ##gc assign-registers-in-insn
+ ! This works because ##gc is always the first instruction
+ ! in a block.
dup call-next-method
- dup compute-live-registers >>live-registers
- compute-live-spill-slots >>live-spill-slots
+ basic-block get register-live-ins get at >>live-values
drop ;
M: insn assign-registers-in-insn drop ;
-: init-assignment ( live-intervals -- )
- V{ } clone pending-intervals set
- <min-heap> unhandled-intervals set
- [ H{ } clone ] reg-class-assoc spill-slots set
- init-unhandled ;
+: compute-live-spill-slots ( vregs -- assoc )
+ spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
+
+: compute-live-registers ( n -- assoc )
+ active-intervals register-mapping ;
+
+ERROR: bad-live-values live-values ;
+
+: check-live-values ( assoc -- assoc )
+ check-assignment? get [
+ dup values [ not ] any? [ bad-live-values ] when
+ ] when ;
+
+: compute-live-values ( vregs n -- assoc )
+ ! If a live vreg is not in active or inactive, then it must have been
+ ! spilled.
+ [ compute-live-spill-slots ] [ compute-live-registers ] bi*
+ assoc-union check-live-values ;
+
+: begin-block ( bb -- )
+ dup basic-block set
+ dup block-from prepare-insn
+ [ [ live-in ] [ block-from ] bi compute-live-values ] keep
+ register-live-ins get set-at ;
+
+: end-block ( bb -- )
+ [ [ live-out ] [ block-to ] bi compute-live-values ] keep
+ register-live-outs get set-at ;
+
+ERROR: bad-vreg vreg ;
+
+: vreg-at-start ( vreg bb -- state )
+ register-live-ins get at ?at [ bad-vreg ] unless ;
+
+: vreg-at-end ( vreg bb -- state )
+ register-live-outs get at ?at [ bad-vreg ] unless ;
-: assign-registers-in-block ( bb -- )
- [
+:: assign-registers-in-block ( bb -- )
+ bb [
[
+ bb begin-block
[
- [
- insn#>>
- [ expire-old-intervals ]
- [ activate-new-intervals ]
- bi
- ]
- [ assign-registers-in-insn ]
- [ , ]
- tri
+ {
+ [ insn#>> 1 - prepare-insn ]
+ [ insn#>> prepare-insn ]
+ [ assign-registers-in-insn ]
+ [ , ]
+ } cleave
] each
+ bb end-block
] V{ } make
] change-instructions drop ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry
namespaces prettyprint compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation compiler.cfg ;
+compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- )
] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- )
- [ [ clone ] map ] dip allocate-registers
+ [
+ [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
+ live-intervals set
+ ] dip allocate-registers
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
-math.order grouping
+math.order grouping strings strings.private
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.linearization
compiler.cfg.debugger
compiler.cfg.linear-scan
+compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
-compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ;
+FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
+
check-allocation? on
+check-assignment? on
+check-numbering? on
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
-[ 7 ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 7 10 } }
- }
- 4 [ >= ] find-use
-] unit-test
-
-[ 4 ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 4 10 } }
- }
- 4 [ >= ] find-use
-] unit-test
-
-[ f ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 4 10 } }
- }
- 100 [ >= ] find-use
-] unit-test
-
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
} 0 split-for-spill [ f >>split-next ] bi@
] unit-test
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 0 }
+ { uses V{ 0 } }
+ { ranges V{ T{ live-range f 0 0 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 20 }
+ { end 30 }
+ { uses V{ 20 30 } }
+ { ranges V{ T{ live-range f 20 30 } } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 30 }
+ { uses V{ 0 20 30 } }
+ { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+ } 10 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 10 }
- { uses V{ 3 10 } }
- }
-] [
- {
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 15 }
- { uses V{ 1 3 7 10 15 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 8 }
- { uses V{ 3 4 8 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 10 }
- { uses V{ 3 10 } }
- }
+ { start 0 }
+ { end 4 }
+ { uses V{ 0 1 4 } }
+ { ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
- { end 5 }
- { uses V{ 5 } }
+ { end 10 }
+ { uses V{ 5 10 } }
+ { ranges V{ T{ live-range f 5 10 } } }
}
- interval-to-spill
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ } 5 split-before-use [ f >>split-next ] bi@
] unit-test
-[ t ] [
+[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 15 }
- { uses V{ 5 10 15 } }
+ { start 0 }
+ { end 4 }
+ { uses V{ 0 1 4 } }
+ { ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 20 } }
+ { start 5 }
+ { end 10 }
+ { uses V{ 5 10 } }
+ { ranges V{ T{ live-range f 5 10 } } }
}
- spill-existing?
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 4 5 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ } 5 split-before-use [ f >>split-next ] bi@
] unit-test
-[ f ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 15 }
- { uses V{ 5 10 15 } }
+[
+ {
+ 3
+ 10
}
+] [
+ H{
+ { int-regs
+ V{
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { reg 1 }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 3 7 10 15 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { reg 2 }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 4 8 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { reg 3 }
+ { start 3 }
+ { end 10 }
+ { uses V{ 3 10 } }
+ }
+ }
+ }
+ } active-intervals set
+ H{ } inactive-intervals set
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 7 20 } }
+ { start 5 }
+ { end 5 }
+ { uses V{ 5 } }
}
- spill-existing?
+ spill-status
] unit-test
-[ t ] [
+[
+ {
+ 1
+ 1/0.
+ }
+] [
+ H{
+ { int-regs
+ V{
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { reg 1 }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { reg 2 }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 8 } }
+ }
+ }
+ }
+ } active-intervals set
+ H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 7 20 } }
- }
- spill-existing?
+ spill-status
] unit-test
[ ] [
! Spill slot liveness was computed incorrectly, leading to a FEP
! early in bootstrap on x86-32
-[ t t ] [
+[ t ] [
[
H{ } clone live-ins set
H{ } clone live-outs set
}
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
instructions>> first
- [ live-spill-slots>> empty? ]
- [ live-registers>> empty? ] bi
+ live-values>> assoc-empty?
] with-scope
] unit-test
intersect-live-ranges
] unit-test
+[ f ] [
+ {
+ T{ live-range f 0 10 }
+ T{ live-range f 20 30 }
+ T{ live-range f 40 50 }
+ }
+ {
+ T{ live-range f 11 15 }
+ T{ live-range f 31 36 }
+ T{ live-range f 51 55 }
+ }
+ intersect-live-ranges
+] unit-test
+
[ 5 ] [
T{ live-interval
{ start 0 }
relevant-ranges intersect-live-ranges
] unit-test
+! register-status had problems because it used map>assoc where the sequence
+! had multiple keys
+[ { 0 10 } ] [
+ H{ { int-regs { 0 1 } } } registers set
+ H{
+ { int-regs
+ {
+ T{ live-interval
+ { vreg V int-regs 1 }
+ { start 0 }
+ { end 20 }
+ { reg 0 }
+ { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
+ { uses V{ 0 2 10 20 } }
+ }
+
+ T{ live-interval
+ { vreg V int-regs 2 }
+ { start 4 }
+ { end 40 }
+ { reg 0 }
+ { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
+ { uses V{ 4 6 30 40 } }
+ }
+ }
+ }
+ } inactive-intervals set
+ H{
+ { int-regs
+ {
+ T{ live-interval
+ { vreg V int-regs 3 }
+ { start 0 }
+ { end 40 }
+ { reg 1 }
+ { ranges V{ T{ live-range f 0 40 } } }
+ { uses V{ 0 40 } }
+ }
+ }
+ }
+ } active-intervals set
+
+ T{ live-interval
+ { vreg V int-regs 4 }
+ { start 8 }
+ { end 10 }
+ { ranges V{ T{ live-range f 8 10 } } }
+ { uses V{ 8 10 } }
+ }
+ register-status
+] unit-test
+
! Bug in live spill slots calculation
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- )
- [ ] [
+ [
cfg new 0 get >>entry
compute-predecessors
compute-liveness
dup reverse-post-order
{ { int-regs regs } } (linear-scan)
flatten-cfg 1array mr.
- ] unit-test ;
+ ] with-scope ;
! This test has a critical edge -- do we care about these?
-! { 1 2 } test-linear-scan-on-cfg
+! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Similar to the above
! [ swap dup [ rot ] when ]
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Inactive interval handling: splitting active interval
! if it fits in lifetime hole only partially
test-diamond
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
USING: classes ;
test-diamond
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
[ _spill ] [ 2 get instructions>> first class ] unit-test
[ _spill ] [ 3 get instructions>> second class ] unit-test
-[ _reload ] [ 4 get instructions>> first class ] unit-test
\ No newline at end of file
+[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
+
+[ _reload ] [ 4 get instructions>> first class ] unit-test
+
+! Resolve pass
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##replace f V int-regs 1 D 0 }
+ T{ ##replace f V int-regs 2 D 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 4 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 5 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 6 test-bb
+
+0 get 1 get V{ } 1sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get V{ } 1sequence >>successors drop
+3 get 4 get V{ } 1sequence >>successors drop
+4 get 5 get 6 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
+
+! A more complicated failure case with resolve that came up after the above
+! got fixed
+V{ T{ ##branch } } 0 test-bb
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 4 D 0 }
+ T{ ##branch }
+} 1 test-bb
+V{ T{ ##branch } } 2 test-bb
+V{ T{ ##branch } } 3 test-bb
+V{
+
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f V int-regs 4 D 4 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##branch }
+} 4 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
+V{ T{ ##return } } 6 test-bb
+V{ T{ ##branch } } 7 test-bb
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 5 D 1 }
+ T{ ##peek f V int-regs 6 D 2 }
+ T{ ##peek f V int-regs 7 D 3 }
+ T{ ##peek f V int-regs 8 D 4 }
+ T{ ##replace f V int-regs 5 D 1 }
+ T{ ##replace f V int-regs 6 D 2 }
+ T{ ##replace f V int-regs 7 D 3 }
+ T{ ##replace f V int-regs 8 D 4 }
+ T{ ##branch }
+} 8 test-bb
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##return }
+} 9 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 7 get V{ } 2sequence >>successors drop
+7 get 8 get 1vector >>successors drop
+8 get 9 get 1vector >>successors drop
+2 get 3 get 5 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 9 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
+
+[ _spill ] [ 1 get instructions>> second class ] unit-test
+[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
+
+! Resolve pass should insert this
+[ _reload ] [ 5 get instructions>> first class ] unit-test
+
+! Some random bug
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 0 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 0 D 3 }
+ T{ ##branch }
+} 2 test-bb
+
+V{ T{ ##branch } } 3 test-bb
+
+V{
+ T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+! Spilling an interval immediately after its activated;
+! and the interval does not have a use at the activation point
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{ T{ ##branch } } 4 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 5 test-bb
+
+1 get 1vector 0 get (>>successors)
+2 get 4 get V{ } 2sequence 1 get (>>successors)
+5 get 1vector 4 get (>>successors)
+3 get 1vector 2 get (>>successors)
+5 get 1vector 3 get (>>successors)
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+! Reduction of push-all regression, x86-32
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##load-immediate { dst V int-regs 61 } }
+ T{ ##peek { dst V int-regs 62 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 64 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 69 }
+ { obj V int-regs 64 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
+ T{ ##slot-imm
+ { dst V int-regs 85 }
+ { obj V int-regs 62 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 69 }
+ { src2 V int-regs 85 }
+ { cc cc> }
+ }
+} 1 test-bb
+
+V{
+ T{ ##slot-imm
+ { dst V int-regs 97 }
+ { obj V int-regs 62 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##replace { src V int-regs 79 } { loc D 3 } }
+ T{ ##replace { src V int-regs 62 } { loc D 4 } }
+ T{ ##replace { src V int-regs 79 } { loc D 1 } }
+ T{ ##replace { src V int-regs 62 } { loc D 2 } }
+ T{ ##replace { src V int-regs 61 } { loc D 5 } }
+ T{ ##replace { src V int-regs 62 } { loc R 0 } }
+ T{ ##replace { src V int-regs 69 } { loc R 1 } }
+ T{ ##replace { src V int-regs 97 } { loc D 0 } }
+ T{ ##call { word resize-array } }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 98 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 100 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 100 }
+ { obj V int-regs 98 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 108 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 110 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 112 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 114 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 116 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 119 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
+ T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
+ T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
+ T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
+ T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
+ T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
+ T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##replace { src V int-regs 120 } { loc D 0 } }
+ T{ ##replace { src V int-regs 109 } { loc D 3 } }
+ T{ ##replace { src V int-regs 111 } { loc D 4 } }
+ T{ ##replace { src V int-regs 113 } { loc D 1 } }
+ T{ ##replace { src V int-regs 115 } { loc D 2 } }
+ T{ ##replace { src V int-regs 117 } { loc D 5 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 4 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 5 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Another reduction of push-all
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 85 } { loc D 0 } }
+ T{ ##slot-imm
+ { dst V int-regs 89 }
+ { obj V int-regs 85 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 91 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 96 }
+ { obj V int-regs 91 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##add
+ { dst V int-regs 109 }
+ { src1 V int-regs 89 }
+ { src2 V int-regs 96 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 115 }
+ { obj V int-regs 85 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 118 }
+ { obj V int-regs 115 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 109 }
+ { src2 V int-regs 118 }
+ { cc cc> }
+ }
+} 1 test-bb
+
+V{
+ T{ ##add-imm
+ { dst V int-regs 128 }
+ { src1 V int-regs 109 }
+ { src2 8 }
+ }
+ T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
+ T{ ##inc-d { n 4 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 109 } { loc D 2 } }
+ T{ ##replace { src V int-regs 85 } { loc D 3 } }
+ T{ ##replace { src V int-regs 128 } { loc D 0 } }
+ T{ ##replace { src V int-regs 85 } { loc D 1 } }
+ T{ ##replace { src V int-regs 89 } { loc D 4 } }
+ T{ ##replace { src V int-regs 96 } { loc R 0 } }
+ T{ ##fixnum-mul
+ { src1 V int-regs 128 }
+ { src2 V int-regs 129 }
+ { temp1 V int-regs 132 }
+ { temp2 V int-regs 133 }
+ }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 134 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 140 }
+ { obj V int-regs 134 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 140 } { loc D 0 } }
+ T{ ##replace { src V int-regs 134 } { loc R 0 } }
+ T{ ##call { word resize-array } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 141 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 143 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 143 }
+ { obj V int-regs 141 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##write-barrier
+ { src V int-regs 141 }
+ { card# V int-regs 145 }
+ { table V int-regs 146 }
+ }
+ T{ ##inc-d { n -1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##peek { dst V int-regs 156 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 158 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 160 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 162 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 164 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 167 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
+ T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
+ T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
+ T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
+ T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
+ T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##inc-d { n 3 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
+ T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
+ T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
+ T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
+ T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
+ T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##set-slot-imm
+ { src V int-regs 163 }
+ { obj V int-regs 161 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##replace { src V int-regs 168 } { loc D 0 } }
+ T{ ##replace { src V int-regs 157 } { loc D 3 } }
+ T{ ##replace { src V int-regs 159 } { loc D 4 } }
+ T{ ##replace { src V int-regs 161 } { loc D 1 } }
+ T{ ##replace { src V int-regs 163 } { loc D 2 } }
+ T{ ##replace { src V int-regs 165 } { loc D 5 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 6 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 5 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Another push-all reduction to demonstrate numbering anamoly
+V{ T{ ##prologue } T{ ##branch } }
+0 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 1 } { loc D 0 } }
+ T{ ##slot-imm
+ { dst V int-regs 5 }
+ { obj V int-regs 1 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 7 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 12 }
+ { obj V int-regs 7 }
+ { slot 1 }
+ { tag 6 }
+ }
+ T{ ##add
+ { dst V int-regs 25 }
+ { src1 V int-regs 5 }
+ { src2 V int-regs 12 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 25 }
+ { src2 V int-regs 5 }
+ { cc cc> }
+ }
+}
+1 test-bb
+
+V{
+ T{ ##slot-imm
+ { dst V int-regs 41 }
+ { obj V int-regs 1 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 44 }
+ { obj V int-regs 41 }
+ { slot 1 }
+ { tag 6 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 25 }
+ { src2 V int-regs 44 }
+ { cc cc> }
+ }
+}
+2 test-bb
+
+V{
+ T{ ##add-imm
+ { dst V int-regs 54 }
+ { src1 V int-regs 25 }
+ { src2 8 }
+ }
+ T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
+ T{ ##inc-d { n 4 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 25 } { loc D 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 3 } }
+ T{ ##replace { src V int-regs 5 } { loc D 4 } }
+ T{ ##replace { src V int-regs 1 } { loc D 1 } }
+ T{ ##replace { src V int-regs 54 } { loc D 0 } }
+ T{ ##replace { src V int-regs 12 } { loc R 0 } }
+ T{ ##fixnum-mul
+ { src1 V int-regs 54 }
+ { src2 V int-regs 55 }
+ { temp1 V int-regs 58 }
+ { temp2 V int-regs 59 }
+ }
+ T{ ##branch }
+}
+3 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 60 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 66 }
+ { obj V int-regs 60 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 66 } { loc D 0 } }
+ T{ ##replace { src V int-regs 60 } { loc R 0 } }
+ T{ ##call { word resize-string } }
+ T{ ##branch }
+}
+4 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 67 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 68 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 68 }
+ { obj V int-regs 67 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##write-barrier
+ { src V int-regs 67 }
+ { card# V int-regs 75 }
+ { table V int-regs 76 }
+ }
+ T{ ##inc-d { n -1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##peek { dst V int-regs 94 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 96 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 98 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 100 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 102 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 106 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
+ T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
+ T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
+ T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
+ T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
+ T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
+ T{ ##branch }
+}
+5 test-bb
+
+V{
+ T{ ##inc-d { n 3 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
+ T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
+ T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
+ T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
+ T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
+ T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
+ T{ ##branch }
+}
+6 test-bb
+
+V{
+ T{ ##load-immediate
+ { dst V int-regs 78 }
+ { val 4611686018427387896 }
+ }
+ T{ ##and
+ { dst V int-regs 81 }
+ { src1 V int-regs 97 }
+ { src2 V int-regs 78 }
+ }
+ T{ ##set-slot-imm
+ { src V int-regs 81 }
+ { obj V int-regs 95 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n -2 } }
+ T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
+ T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
+ T{ ##branch }
+}
+7 test-bb
+
+V{
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
+ T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
+ T{ ##branch }
+}
+8 test-bb
+
+V{
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##replace { src V int-regs 117 } { loc D 0 } }
+ T{ ##replace { src V int-regs 110 } { loc D 1 } }
+ T{ ##replace { src V int-regs 111 } { loc D 2 } }
+ T{ ##replace { src V int-regs 112 } { loc D 3 } }
+ T{ ##epilogue }
+ T{ ##return }
+}
+9 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 8 get V{ } 2sequence >>successors drop
+2 get 3 get 6 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+5 get 7 get 1vector >>successors drop
+6 get 7 get 1vector >>successors drop
+7 get 9 get 1vector >>successors drop
+8 get 9 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
\ No newline at end of file
rpo number-instructions
rpo compute-live-intervals machine-registers allocate-registers
rpo assign-registers
- rpo resolve-data-flow ;
+ rpo resolve-data-flow
+ rpo check-numbering ;
: linear-scan ( cfg -- cfg' )
[
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
-binary-search combinators compiler.cfg.instructions compiler.cfg.registers
+combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
V{ } clone >>ranges
swap >>vreg ;
-: block-from ( bb -- n ) instructions>> first insn#>> ;
+: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
<reversed> [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
-: relevant-ranges ( new inactive -- new' inactive' )
- ! Slice off all ranges of 'inactive' that precede the start of 'new'
+: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
- { [ over empty? ] [ 2drop 1/0. ] }
- { [ dup empty? ] [ 2drop 1/0. ] }
+ { [ over empty? ] [ 2drop f ] }
+ { [ dup empty? ] [ 2drop f ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
] if
]
} cond ;
+
+: intervals-intersect? ( interval1 interval2 -- ? )
+ relevant-ranges intersect-live-ranges >boolean ; inline
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math sequences ;
+USING: kernel accessors math sequences grouping namespaces ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
- ] each drop ;
\ No newline at end of file
+ ] each drop ;
+
+SYMBOL: check-numbering?
+
+ERROR: bad-numbering bb ;
+
+: check-block-numbering ( bb -- )
+ dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
+ [ drop ] [ bad-numbering ] if ;
+
+: check-numbering ( rpo -- )
+ check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ;
\ No newline at end of file
compiler.cfg.linear-scan.debugger
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering
+compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
namespaces tools.test vectors ;
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
] unit-test
-V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##return }
-} 1 test-bb
-
-1 get 1vector 0 get (>>successors)
-
-cfg new 0 get >>entry
-compute-predecessors
-dup reverse-post-order number-instructions
-drop
-
-CONSTANT: test-live-interval-1
-T{ live-interval
- { start 0 }
- { end 6 }
- { uses V{ 0 6 } }
- { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
- { spill-to 0 }
- { vreg V int-regs 0 }
-}
-
-[ f ] [
- 0 get test-live-interval-1 spill-to
-] unit-test
-
-[ 0 ] [
- 1 get test-live-interval-1 spill-to
-] unit-test
-
-CONSTANT: test-live-interval-2
-T{ live-interval
- { start 0 }
- { end 6 }
- { uses V{ 0 6 } }
- { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
- { reload-from 0 }
- { vreg V int-regs 0 }
-}
-
-[ 0 ] [
- 0 get test-live-interval-2 reload-from
-] unit-test
-
-[ f ] [
- 1 get test-live-interval-2 reload-from
-] unit-test
+H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+H{ } clone spill-temps set
[
{
T{ _copy { dst 5 } { src 4 } { class int-regs } }
- T{ _spill { src 0 } { class int-regs } { n 6 } }
- T{ _copy { dst 0 } { src 1 } { class int-regs } }
- T{ _reload { dst 1 } { class int-regs } { n 6 } }
- T{ _spill { src 0 } { class float-regs } { n 7 } }
- T{ _copy { dst 0 } { src 1 } { class float-regs } }
- T{ _reload { dst 1 } { class float-regs } { n 7 } }
+ T{ _spill { src 1 } { class int-regs } { n 10 } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ T{ _spill { src 1 } { class float-regs } { n 20 } }
+ T{ _copy { dst 1 } { src 0 } { class float-regs } }
+ T{ _reload { dst 0 } { class float-regs } { n 20 } }
}
] [
{
[
{
- T{ _spill { src 0 } { class int-regs } { n 3 } }
- T{ _copy { dst 0 } { src 2 } { class int-regs } }
+ T{ _spill { src 2 } { class int-regs } { n 10 } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
- T{ _reload { dst 1 } { class int-regs } { n 3 } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
}
] [
{
[
{
- T{ _spill { src 0 } { class int-regs } { n 3 } }
+ T{ _spill { src 0 } { class int-regs } { n 10 } }
T{ _copy { dst 0 } { src 2 } { class int-regs } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
- T{ _reload { dst 1 } { class int-regs } { n 3 } }
+ T{ _reload { dst 1 } { class int-regs } { n 10 } }
}
] [
{
] unit-test
[
- { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+ {
+ T{ _spill { src 3 } { class int-regs } { n 4 } }
+ T{ _reload { dst 2 } { class int-regs } { n 1 } }
+ }
] [
{
- T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+ T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
+ T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
- T{ _spill { src 3 } { class int-regs } { n 5 } }
+ T{ _spill { src 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
- T{ _copy { dst 3 } { src 4 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 5 } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 9 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _spill { src 3 } { class int-regs } { n 10 } }
+ T{ _spill { src 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
- T{ _copy { dst 3 } { src 4 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
USING: accessors arrays assocs classes.parser classes.tuple
combinators combinators.short-circuit fry hashtables kernel locals
make math math.order namespaces sequences sets words parser
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
-compiler.cfg.liveness ;
+compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve
+SYMBOL: spill-temps
+
+: spill-temp ( reg-class -- n )
+ spill-temps get [ next-spill-slot ] cache ;
+
<<
TUPLE: operation from to reg-class ;
SYNTAX: OPERATION:
CREATE-CLASS dup save-location
[ operation { } define-tuple-class ]
- [
- [ scan-word scan-word ] keep
- '[
- [ [ _ execute ] [ _ execute ] bi* ]
- [ vreg>> reg-class>> ]
- bi _ boa ,
- ] (( from to -- )) define-declared
- ] bi ;
+ [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
>>
-: reload-from ( bb live-interval -- n/f )
- 2dup [ block-from ] [ start>> ] bi* =
- [ nip reload-from>> ] [ 2drop f ] if ;
+OPERATION: register->memory
+OPERATION: memory->register
+OPERATION: register->register
-: spill-to ( bb live-interval -- n/f )
- 2dup [ block-to ] [ end>> ] bi* =
- [ nip spill-to>> ] [ 2drop f ] if ;
+! This should never come up because of how spill slots are assigned,
+! so make it an error.
+: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
-OPERATION: memory->memory spill-to>> reload-from>>
-OPERATION: register->memory reg>> reload-from>>
-OPERATION: memory->register spill-to>> reg>>
-OPERATION: register->register reg>> reg>>
-
-:: add-mapping ( bb1 bb2 li1 li2 -- )
- bb2 li2 reload-from [
- bb1 li1 spill-to
- [ li1 li2 memory->memory ]
- [ li1 li2 register->memory ] if
+: add-mapping ( from to reg-class -- )
+ over spill-slot? [
+ pick spill-slot?
+ [ memory->memory ]
+ [ register->memory ] if
] [
- bb1 li1 spill-to
- [ li1 li2 memory->register ]
- [ li1 li2 register->register ] if
+ pick spill-slot?
+ [ memory->register ]
+ [ register->register ] if
] if ;
-: resolve-value-data-flow ( bb to vreg -- )
- [ 2dup ] dip
- live-intervals get at
- [ [ block-to ] dip child-interval-at ]
- [ [ block-from ] dip child-interval-at ]
- bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
+:: resolve-value-data-flow ( bb to vreg -- )
+ vreg bb vreg-at-end
+ vreg to vreg-at-start
+ 2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
[
GENERIC: >insn ( operation -- )
-M: memory->memory >insn
- [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
M: register->memory >insn
- [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+ [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
M: memory->register >insn
- [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+ [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
-GENERIC: >collision-table ( operation -- )
-
-M: memory->memory >collision-table
- [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
-M: register->memory >collision-table
- [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
-
-M: memory->register >collision-table
- [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
-
-M: register->register >collision-table
- [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
-
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
-GENERIC: from-loc ( operation -- obj )
-M: memory->memory from-loc drop memory ;
-M: register->memory from-loc drop register ;
-M: memory->register from-loc drop memory ;
-M: register->register from-loc drop register ;
+: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
-GENERIC: to-loc ( operation -- obj )
-M: memory->memory to-loc drop memory ;
-M: register->memory to-loc drop memory ;
-M: memory->register to-loc drop register ;
-M: register->register to-loc drop register ;
+: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
-: init-temp-spill ( operations -- )
- [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
- 1 + temp-spill set ;
-
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
+ dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
- [ (trace-chain) ] [ , drop ] if
+ [ (trace-chain) ] [ 2drop ] if
] [
- drop hashtable ,
+ drop
] if ;
: trace-chain ( obj -- seq )
[
+ dup ,
dup dup associate (trace-chain)
- ] { } make [ keys ] map concat reverse ;
+ ] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
-: break-cycle-n ( operations -- operations' )
+ERROR: resolve-error ;
+
+: split-cycle ( operations -- chain spilled-operation )
unclip [
- [ from>> temp-spill get ]
- [ reg-class>> ] bi \ register->memory boa
+ [ set-tos/froms ]
+ [
+ [ start? ] find nip
+ [ resolve-error ] unless* trace-chain
+ ] bi
+ ] dip ;
+
+: break-cycle-n ( operations -- operations' )
+ split-cycle [
+ [ from>> ]
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ reg-class>> ]
+ tri \ register->memory boa
] [
- [ to>> temp-spill [ get ] [ inc ] bi swap ]
- [ reg-class>> ] bi \ memory->register boa
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ to>> ]
+ [ reg-class>> ]
+ tri \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
: mapping-instructions ( mappings -- insns )
[
- [ init-temp-spill ]
- [ set-tos/froms ]
- [ parallel-mappings ] tri
+ [ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope ;
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
+ H{ } clone spill-temps set
[ resolve-block-data-flow ] each ;
#! don't need to branch.
[ number>> ] bi@ 1 - = ; inline
-: branch-to-branch? ( successor -- ? )
- #! A branch to a block containing just a jump return is cloned.
- instructions>> dup length 2 = [
- [ first ##epilogue? ]
- [ second [ ##return? ] [ ##jump? ] bi or ] bi and
- ] [ drop f ] if ;
-
: emit-branch ( basic-block successor -- )
- {
- { [ 2dup useless-branch? ] [ 2drop ] }
- { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
- [ nip number>> _branch ]
- } cond ;
+ 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
-: gc-root-registers ( n live-registers -- n )
- [
- [ second 2array , ]
- [ first reg-class>> reg-size + ]
- 2bi
- ] each ;
-
-: gc-root-spill-slots ( n live-spill-slots -- n )
+: (compute-gc-roots) ( n live-values -- n )
[
- dup first reg-class>> int-regs eq? [
- [ second <spill-slot> 2array , ]
- [ first reg-class>> reg-size + ]
- 2bi
- ] [ drop ] if
- ] each ;
+ [ nip 2array , ]
+ [ drop reg-class>> reg-size + ]
+ 3bi
+ ] assoc-each ;
-: oop-registers ( regs -- regs' )
- [ first reg-class>> int-regs eq? ] filter ;
+: oop-values ( regs -- regs' )
+ [ drop reg-class>> int-regs eq? ] assoc-filter ;
-: data-registers ( regs -- regs' )
- [ first reg-class>> double-float-regs eq? ] filter ;
+: data-values ( regs -- regs' )
+ [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
-:: compute-gc-roots ( live-registers live-spill-slots -- alist )
+: compute-gc-roots ( live-values -- alist )
[
- 0
+ [ 0 ] dip
! we put float registers last; the GC doesn't actually scan them
- live-registers oop-registers gc-root-registers
- live-spill-slots gc-root-spill-slots
- live-registers data-registers gc-root-registers
+ [ oop-values (compute-gc-roots) ]
+ [ data-values (compute-gc-roots) ] bi
drop
] { } make ;
-: count-gc-roots ( live-registers live-spill-slots -- n )
+: count-gc-roots ( live-values -- n )
! Size of GC root area, minus the float registers
- [ oop-registers length ] bi@ + ;
+ oop-values assoc-size ;
M: ##gc linearize-insn
nip
[ temp1>> ]
[ temp2>> ]
[
- [ live-registers>> ] [ live-spill-slots>> ] bi
+ live-values>>
[ compute-gc-roots ]
[ count-gc-roots ]
[ gc-roots-size ]
- 2tri
+ tri
] tri
_gc
] with-regs ;
--- /dev/null
+USING: compiler.cfg compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.liveness accessors tools.test cpu.architecture ;
+IN: compiler.cfg.liveness.tests
+
+[
+ H{
+ { "A" H{ { V int-regs 1 V int-regs 1 } { V int-regs 4 V int-regs 4 } } }
+ { "B" H{ { V int-regs 3 V int-regs 3 } { V int-regs 2 V int-regs 2 } } }
+ }
+] [
+ <basic-block> V{
+ T{ ##phi f V int-regs 0 { { "A" V int-regs 1 } { "B" V int-regs 2 } } }
+ T{ ##phi f V int-regs 1 { { "B" V int-regs 3 } { "A" V int-regs 4 } } }
+ } >>instructions compute-phi-live-in
+] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
-dlists compiler.cfg.def-use compiler.cfg.instructions
+hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo ;
IN: compiler.cfg.liveness
! is in conrrespondence with a predecessor
SYMBOL: phi-live-ins
-: phi-live-in ( predecessor basic-block -- set )
- [ predecessors>> index ] keep phi-live-ins get at
- dup [ nth ] [ 2drop f ] if ;
+: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
! Assoc mapping basic blocks to sets of vregs
SYMBOL: live-outs
[ nip kill-set ]
2bi assoc-diff ;
+: conjoin-at ( value key assoc -- )
+ [ dupd ?set-at ] change-at ;
+
: compute-phi-live-in ( basic-block -- phi-live-in )
- instructions>> [ ##phi? ] filter
- [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
+ instructions>> [ ##phi? ] filter [ f ] [
+ H{ } clone [
+ '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
+ ] keep
+ ] if-empty ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
-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 slots.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
} [
[ [ ] ] 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
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
+compiler.cfg.tco
compiler.cfg.predecessors
-compiler.cfg.useless-blocks
+compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
+compiler.cfg.branch-splitting
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
+compiler.cfg.branch-folding
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
] when ;
: optimize-cfg ( cfg -- cfg' )
+ ! Note that compute-predecessors has to be called several times.
+ ! The passes that need this document it.
[
+ optimize-tail-calls
compute-predecessors
- ! delete-useless-blocks
delete-useless-conditionals
+ split-branches
+ compute-predecessors
stack-analysis
compute-liveness
alias-analysis
value-numbering
+ fold-branches
+ compute-predecessors
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
--- /dev/null
+IN: compiler.cfg.phi-elimination.tests
+USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
+compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors
+sequences classes namespaces tools.test cpu.architecture arrays ;
+
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 { } }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ 2 ] [ 4 get instructions>> length ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo fry kernel sequences ;
+USING: accessors assocs fry kernel sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
'[ _ _ swap ##copy ] add-instructions ;
-: eliminate-phi ( bb ##phi -- )
- [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
- '[ _ insert-copy ] 2each ;
+: eliminate-phi ( ##phi -- )
+ [ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
: eliminate-phi-step ( bb -- )
- dup [
- [ ##phi? ] partition
- [ [ eliminate-phi ] with each ] dip
- ] change-instructions drop ;
+ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
: eliminate-phis ( cfg -- cfg' )
dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences compiler.cfg.rpo ;
+USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
+compiler.cfg.instructions ;
IN: compiler.cfg.predecessors
-: predecessors-step ( bb -- )
+: update-predecessors ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
+: update-phi ( bb ##phi -- )
+ [
+ swap predecessors>>
+ '[ drop _ memq? ] assoc-filter
+ ] change-inputs drop ;
+
+: update-phis ( bb -- )
+ dup instructions>> [
+ dup ##phi? [ update-phi ] [ 2drop ] if
+ ] with each ;
+
: compute-predecessors ( cfg -- cfg' )
- [ [ V{ } clone >>predecessors drop ] each-basic-block ]
- [ [ predecessors-step ] each-basic-block ]
- [ ]
- tri ;
+ {
+ [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+ [ [ update-predecessors ] each-basic-block ]
+ [ [ update-phis ] each-basic-block ]
+ [ ]
+ } cleave ;
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
- [ merge-locs locs>vregs>> keys ] { } make first inputs>>
+ [ merge-locs locs>vregs>> keys ] { } make first inputs>> values
] unit-test
[
: merge-loc ( predecessors vregs loc state -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
+ [ dup ] 3dip
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
- dup all-equal? [ first ] [ ^^phi ] if ;
+ dup all-equal? [ nip first ] [ zip ^^phi ] if ;
:: merge-locs ( state predecessors states -- state )
states [ locs>vregs>> ] map states collect-locs
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.rpo
-compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
+compiler.cfg.dce compiler.cfg.registers
sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
-local-only? off
-
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
! Instructions which don't have any effect on the stack
UNION: neutral-insn
##effect
- ##flushable ;
+ ##flushable
+ ##no-tco ;
M: neutral-insn visit , ;
##dispatch
##loop-entry ;
-SYMBOL: local-only?
-
-t local-only? set-global
-
: back-edge? ( from to -- ? )
[ number>> ] bi@ > ;
: sync-state? ( -- ? )
basic-block get successors>>
- [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
- local-only? get or ;
+ [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
sync-state? [ sync-state ] when , ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
-: gc-roots-size ( live-registers live-spill-slots -- n )
- [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+: gc-roots-size ( live-values -- n )
+ keys [ reg-class>> reg-size ] sigma ;
: (stack-frame-size) ( stack-frame -- n )
[
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math
+namespaces sequences fry combinators
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.instructions ;
+IN: compiler.cfg.tco
+
+! Tail call optimization. You must run compute-predecessors after this
+
+: return? ( bb -- ? )
+ skip-empty-blocks
+ instructions>> {
+ [ length 2 = ]
+ [ first ##epilogue? ]
+ [ second ##return? ]
+ } 1&& ;
+
+: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
+
+: tail-call? ( bb -- ? )
+ {
+ [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
+ [ successors>> first return? ]
+ } 1&& ;
+
+: word-tail-call? ( bb -- ? )
+ instructions>> penultimate ##call? ;
+
+: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
+ '[
+ instructions>>
+ [ pop* ] [ pop ] [ ] tri
+ [ [ \ ##epilogue new-insn ] dip push ]
+ [ _ dip push ] bi
+ ]
+ [ successors>> delete-all ]
+ bi ; inline
+
+: convert-word-tail-call ( bb -- )
+ [ word>> \ ##jump new-insn ] convert-tail-call ;
+
+: loop-tail-call? ( bb -- ? )
+ instructions>> penultimate
+ { [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
+
+: convert-loop-tail-call ( bb -- )
+ ! If a word calls itself, this becomes a loop in the CFG.
+ [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
+ [ successors>> delete-all ]
+ [ [ cfg get entry>> successors>> first ] dip successors>> push ]
+ tri ;
+
+: fixnum-tail-call? ( bb -- ? )
+ instructions>> penultimate
+ { [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
+
+GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
+
+M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
+M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
+M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
+
+: convert-fixnum-tail-call ( bb -- )
+ [
+ [ src1>> ] [ src2>> ] [ ] tri
+ convert-fixnum-tail-call*
+ ] convert-tail-call ;
+
+: optimize-tail-call ( bb -- )
+ dup tail-call? [
+ {
+ { [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
+ { [ dup word-tail-call? ] [ convert-word-tail-call ] }
+ { [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
+ [ drop ]
+ } cond
+ ] [ drop ] if ;
+
+: optimize-tail-calls ( cfg -- cfg' )
+ dup cfg set
+ dup [ optimize-tail-call ] each-basic-block
+ f >>post-order ;
\ No newline at end of file
+++ /dev/null
-Eliminating unreachable basic blocks and unconditional jumps
+++ /dev/null
-IN: compiler.cfg.useless-blocks.tests
-USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
-compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
-
-{
- [ [ drop 1 ] when ]
- [ [ drop 1 ] unless ]
-} [
- [ [ ] ] dip
- '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
-] each
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
-IN: compiler.cfg.useless-blocks
-
-: update-predecessor-for-delete ( bb -- )
- ! We have to replace occurrences of bb with bb's successor
- ! in bb's predecessor's list of successors.
- dup predecessors>> first [
- [
- 2dup eq? [ drop successors>> first ] [ nip ] if
- ] with map
- ] change-successors drop ;
-
-: update-successor-for-delete ( bb -- )
- ! We have to replace occurrences of bb with bb's predecessor
- ! in bb's sucessor's list of predecessors.
- dup successors>> first [
- [
- 2dup eq? [ drop predecessors>> first ] [ nip ] if
- ] with map
- ] change-predecessors drop ;
-
-: delete-basic-block ( bb -- )
- [ update-predecessor-for-delete ]
- [ update-successor-for-delete ]
- bi ;
-
-: delete-basic-block? ( bb -- ? )
- {
- [ instructions>> length 1 = ]
- [ predecessors>> length 1 = ]
- [ successors>> length 1 = ]
- [ instructions>> first ##branch? ]
- } 1&& ;
-
-: delete-useless-blocks ( cfg -- cfg' )
- dup [
- dup delete-basic-block? [ delete-basic-block ] [ drop ] if
- ] each-basic-block
- f >>post-order ;
-
-: delete-conditional? ( bb -- ? )
- dup instructions>> [ drop f ] [
- last class {
- ##compare-branch
- ##compare-imm-branch
- ##compare-float-branch
- } memq? [ successors>> first2 eq? ] [ drop f ] if
- ] if-empty ;
-
-: delete-conditional ( bb -- )
- dup successors>> first 1vector >>successors
- [ but-last \ ##branch new-insn suffix ] change-instructions
- drop ;
-
-: delete-useless-conditionals ( cfg -- cfg' )
- dup [
- dup delete-conditional? [ delete-conditional ] [ drop ] if
- ] each-basic-block
- f >>post-order ;
--- /dev/null
+Eliminating unreachable basic blocks and unconditional jumps
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences math combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.useless-conditionals
+
+: delete-conditional? ( bb -- ? )
+ {
+ [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+ [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
+ } 1&& ;
+
+: delete-conditional ( bb -- )
+ [ first skip-empty-blocks 1vector ] change-successors
+ instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+ dup [
+ dup delete-conditional? [ delete-conditional ] [ drop ] if
+ ] each-basic-block
+ f >>post-order ;
: stop-iterating ( -- next ) end-basic-block f ;
-: call-height ( ##call -- n )
- [ out-d>> length ] [ in-d>> length ] bi - ;
-
: emit-primitive ( node -- )
- [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
+ word>> ##call ##branch begin-basic-block ;
: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
+
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors combinators namespaces
-math fry
-compiler.cfg.hats
-compiler.cfg.instructions
+USING: accessors locals combinators combinators.short-circuit arrays
+fry kernel layouts math namespaces sequences cpu.architecture
+math.bitwise compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.rewrite
GENERIC: rewrite ( insn -- insn' )
-M: ##mul-imm rewrite
- dup src2>> dup power-of-2? [
- [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
- dup number-values
- ] [ drop ] if ;
+M: insn rewrite ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
- [ cc>> cc/= eq? ]
- [ src2>> \ f tag-number eq? ] bi and
+ {
+ [ cc>> cc/= eq? ]
+ [ src2>> \ f tag-number eq? ]
+ } 1&&
] [ drop f ] if ; inline
: rewrite-boolean-comparison? ( insn -- ? )
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
- [ src1>> vreg>expr tag-fixnum-expr? ]
- [ src2>> tag-mask get bitand 0 = ]
- bi and ; inline
+ {
+ [ src1>> vreg>expr tag-fixnum-expr? ]
+ [ src2>> tag-mask get bitand 0 = ]
+ } 1&& ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
] when ;
-: flip-comparison? ( insn -- ? )
- dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
-
-: flip-comparison ( insn -- insn' )
- [ dst>> ]
- [ src2>> ]
- [ src1>> vreg>vn vn>constant ] tri
- cc= i \ ##compare-imm new-insn ;
-
-M: ##compare rewrite
- dup flip-comparison? [
- flip-comparison
- dup number-values
- rewrite
- ] when ;
+:: >compare-imm ( insn swap? -- insn' )
+ insn dst>>
+ insn src1>>
+ insn src2>> swap? [ swap ] when vreg>constant
+ insn cc>> swap? [ swap-cc ] when
+ i \ ##compare-imm new-insn ; inline
+
+! M: ##compare rewrite
+! dup [ src1>> ] [ src2>> ] bi
+! [ vreg>expr constant-expr? ] bi@ 2array {
+! { { f t } [ f >compare-imm ] }
+! { { t f } [ t >compare-imm ] }
+! [ drop ]
+! } case ;
+
+:: >compare-imm-branch ( insn swap? -- insn' )
+ insn src1>>
+ insn src2>> swap? [ swap ] when vreg>constant
+ insn cc>> swap? [ swap-cc ] when
+ \ ##compare-imm-branch new-insn ; inline
+
+! M: ##compare-branch rewrite
+! dup [ src1>> ] [ src2>> ] bi
+! [ vreg>expr constant-expr? ] bi@ 2array {
+! { { f t } [ f >compare-imm-branch ] }
+! { { t f } [ t >compare-imm-branch ] }
+! [ drop ]
+! } case ;
: rewrite-redundant-comparison? ( insn -- ? )
- [ src1>> vreg>expr compare-expr? ]
- [ src2>> \ f tag-number = ]
- [ cc>> { cc= cc/= } memq? ]
- tri and and ; inline
+ {
+ [ src1>> vreg>expr compare-expr? ]
+ [ src2>> \ f tag-number = ]
+ [ cc>> { cc= cc/= } memq? ]
+ } 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
] when
] when ;
-M: insn rewrite ;
+: 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 op combine-imm? [
+ insn quot op (combine-imm)
+ ] [
+ 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) ] }
+ [ ]
+ } cond ;
+
+M: ##sub-imm rewrite
+ {
+ { [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] }
+ { [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] }
+ [ ]
+ } cond ;
+
+M: ##mul-imm rewrite
+ dup src2>> dup power-of-2? [
+ [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
+ dup number-values
+ ] [
+ drop [ * ] \ ##mul-imm combine-imm
+ ] if ;
+
+M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ;
+
+M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
+
+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 rewrite-add? [
+ [ dst>> ]
+ [ src1>> ]
+ [ src2>> vreg>constant ] tri \ ##add-imm new-insn
+ dup number-values
+ ] when ;
+
+M: ##sub rewrite constant-fold ;
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.expressions locals ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
[ 2drop f ]
} cond ; inline
+: simplify-sub ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
: useless-shift? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
dup op>> {
{ \ ##add [ simplify-add ] }
{ \ ##add-imm [ simplify-add ] }
+ { \ ##sub [ simplify-sub ] }
+ { \ ##sub-imm [ simplify-sub ] }
{ \ ##shr-imm [ simplify-shift ] }
{ \ ##sar-imm [ simplify-shift ] }
[ 2drop f ]
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
+M: ##no-tco generate-insn drop ;
+
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
}
] [
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Regression from Doug's value numbering changes
+[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
+[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
\ No newline at end of file
[ 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
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private combinators.short-circuit grouping prettyprint
+generalizations
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
] unit-test
+
+[ [ ] ] [
+ [
+ 20 f <array>
+ [ 0 swap nth ] keep
+ [ 1 swap nth ] keep
+ [ 2 swap nth ] keep
+ [ 3 swap nth ] keep
+ [ 4 swap nth ] keep
+ [ 5 swap nth ] keep
+ [ 6 swap nth ] keep
+ [ 7 swap nth ] keep
+ [ 8 swap nth ] keep
+ [ 9 swap nth ] keep
+ [ 10 swap nth ] keep
+ [ 11 swap nth ] keep
+ [ 12 swap nth ] keep
+ 14 ndrop
+ ] cleaned-up-tree nodes>quot
+] unit-test
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
-fry locals definitions classes.algebra
+fry locals definitions classes classes.algebra generic
stack-checker.state
stack-checker.backend
compiler.tree
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
-: flushable? ( word -- ? )
- [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
+GENERIC: flushable? ( word -- ? )
+
+M: predicate flushable? drop t ;
+
+M: word flushable? "flushable" word-prop ;
+
+M: method-body flushable? "method-generic" word-prop flushable? ;
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
: ?check ( nodes -- nodes' )
check-optimizer? get [
- compute-def-use
dup check-nodes
] when ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types alien.syntax arrays kernel
+USING: locals alien.c-types alien.syntax arrays kernel fry
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture make compiler compiler.units
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
- src HEX: ffffffff ADD
+ temp src HEX: ffffffff [+] LEA
+ building get length cell - :> start
0 rc-absolute-cell rel-here
! Go
- src HEX: 7f [+] JMP
+ temp HEX: 7f [+] JMP
+ building get length :> end
! Fix up the displacement above
cell code-alignment
- [ 7 + building get dup pop* push ]
+ [ end start - + building get dup pop* push ]
[ align-code ]
bi ;
align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
- [ [ align-sub ] [ call ] bi* ]
- [ [ align-add ] [ drop ] bi* ] 2bi ; inline
+ '[ align-sub @ ] [ align-add ] bi ; inline
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
- stack-reg swap 3 cells - SUB ;
+ 3 cells - decr-stack-reg ;
M: object %load-param-reg 3drop ;
M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp -- )
+ building get length :> start
! Load jump table base.
temp HEX: ffffffff MOV
0 rc-absolute-cell rel-here
! Add jump table base
- src temp ADD
- src HEX: 7f [+] JMP
+ temp src ADD
+ temp HEX: 7f [+] JMP
+ building get length :> end
! Fix up the displacement above
cell code-alignment
- [ 15 + building get dup pop* push ]
+ [ end start - 2 - + building get dup pop* push ]
[ align-code ]
bi ;
--- /dev/null
+IN: disjoint-sets.testes
+USING: tools.test disjoint-sets namespaces slots.private ;
+
+SYMBOL: +blah+
+-405534154 +blah+ 1 set-slot
+
+SYMBOL: uf
+
+[ ] [
+ <disjoint-set> uf set
+ +blah+ uf get add-atom
+ 19026 uf get add-atom
+ 19026 +blah+ uf get equate
+] unit-test
+
+[ 2 ] [ 19026 uf get equiv-set-size ] unit-test
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
tools.crossref vocabs.hierarchy prettyprint source-files
-source-files.errors assocs vocabs vocabs.loader splitting
+source-files.errors assocs vocabs.loader splitting
accessors debugger help.topics ;
+FROM: vocabs => vocab-name >vocab-link ;
IN: editors
TUPLE: no-edit-hook ;
SYMBOL: edit-hook
: available-editors ( -- seq )
- "editors" all-child-vocabs-seq [ vocab-name ] map ;
+ "editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors
[ dup name>> >lower ] { } map>assoc ;
: vocab-candidates ( -- candidates )
- all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+ all-vocabs-recursive no-roots no-prefixes
+ [ dup vocab-name >lower ] { } map>assoc ;
: help-candidates ( seq -- candidates )
[ [ >link ] [ article-title >lower ] bi ] { } map>assoc
assocs sequences make words accessors arrays help.topics vocabs
vocabs.hierarchy help.vocabs namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer math.parser ;
+sorting debugger html xml.syntax xml.writer math.parser
+sets hashtables ;
FROM: io.encodings.ascii => ascii ;
FROM: ascii => ascii? ;
IN: help.html
{ CHAR: / "__slash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
+ { CHAR: # "__hash__" }
} at [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ;
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- #! Hack.
- all-vocabs values concat
- vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
+ all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
: all-topics ( -- topics )
[
source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
+FROM: vocabs => child-vocabs ;
IN: help.lint
SYMBOL: lint-failures
: help-lint ( prefix -- )
[
auto-use? off
- all-vocabs-seq [ vocab-name ] map all-vocabs set
+ all-vocab-names all-vocabs set
group-articles vocab-articles set
child-vocabs
[ check-vocab ] each
make namespaces prettyprint sequences sets sorting summary
vocabs vocabs.files vocabs.hierarchy vocabs.loader
vocabs.metadata words words.symbol definitions.icons ;
+FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
$heading ;
: $vocabs ( seq -- )
- [ vocab-row ] map vocab-headings prefix $table ;
+ convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
: $vocab-roots ( assoc -- )
[
] unless-empty ;
: describe-children ( vocab -- )
- vocab-name all-child-vocabs $vocab-roots ;
+ vocab-name child-vocabs
+ $vocab-roots ;
: files. ( seq -- )
snippet-style get [
ERROR: too-many-redirects ;
-CONSTANT: max-redirects 10
-
<PRIVATE
: write-request-line ( request -- request )
:: do-redirect ( quot: ( chunk -- ) response -- response )
redirects inc
- redirects get max-redirects < [
+ redirects get request get redirects>> < [
request get clone
response "location" header redirect-url
response code>> 307 = [ "GET" >>method ] unless
with-output-stream*
] [
in>> [
- read-response dup redirect? [ t ] [
+ read-response dup redirect?
+ request get redirects>> 0 > and [ t ] [
[ nip response set ]
[ read-response-body ]
[ ]
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel summary debugger io make math.parser
-prettyprint http.client accessors ;
+prettyprint http http.client accessors ;
IN: http.client.debugger
M: too-many-redirects summary
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
{ { $slot "post-data" } { "See " { $link "http.post-data" } } }
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
+ { { $slot "redirects" } { "Number of redirects to attempt before throwing an error. Default is " { $snippet "max-redirects" } " ." } }
} } ;
HELP: <response>
base64 ;
IN: http
+CONSTANT: max-redirects 10
+
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] produce nip ;
version
header
post-data
-cookies ;
+cookies
+redirects ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
H{ } clone >>header
V{ } clone >>cookies
"close" "connection" set-header
- "Factor http.client" "user-agent" set-header ;
+ "Factor http.client" "user-agent" set-header
+ max-redirects >>redirects ;
: header ( request/response key -- value )
swap header>> at ;
INTENSITY DEPTH DEPTH-STENCIL R RG ;
UNION: component-type
- ubyte-components ushort-components
+ ubyte-components ushort-components uint-components
half-components float-components
byte-integer-components ubyte-integer-components
short-integer-components ushort-integer-components
short-integer-components ushort-integer-components
int-integer-components uint-integer-components ;
+UNION: signed-unnormalized-integer-components
+ byte-integer-components
+ short-integer-components
+ int-integer-components ;
+
+UNION: unsigned-unnormalized-integer-components
+ ubyte-integer-components
+ ushort-integer-components
+ uint-integer-components ;
+
UNION: packed-components
u-5-5-5-1-components u-5-6-5-components
u-10-10-10-2-components
{ RG [ 2 ] }
} case ;
-: bytes-per-pixel ( image -- n )
- dup component-type>> packed-components?
- [ component-type>> bytes-per-packed-pixel ] [
- [ component-order>> component-count ]
- [ component-type>> bytes-per-component ] bi *
+: (bytes-per-pixel) ( component-order component-type -- n )
+ dup packed-components?
+ [ nip bytes-per-packed-pixel ] [
+ [ component-count ] [ bytes-per-component ] bi* *
] if ;
+: bytes-per-pixel ( image -- n )
+ [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
+
<PRIVATE
: pixel@ ( x y image -- start end bitmap )
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays columns kernel math math.bits
-math.order math.vectors sequences sequences.private fry ;
+USING: accessors arrays columns kernel locals math math.bits
+math.functions math.order math.vectors sequences
+sequences.private fry ;
IN: math.matrices
! Matrices
#! Make a nxn identity matrix.
dup [ [ = 1 0 ? ] with map ] curry map ;
+:: rotation-matrix3 ( axis theta -- matrix )
+ theta cos :> c
+ theta sin :> s
+ axis first3 :> z :> y :> x
+ x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array
+ x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array
+ x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array
+ 3array ;
+
+:: rotation-matrix4 ( axis theta -- matrix )
+ theta cos :> c
+ theta sin :> s
+ axis first3 :> z :> y :> x
+ x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array
+ x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array
+ x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array
+ { 0.0 0.0 0.0 1.0 } 4array ;
+
+:: translation-matrix4 ( offset -- matrix )
+ offset first3 :> z :> y :> x
+ {
+ { 1.0 0.0 0.0 x }
+ { 0.0 1.0 0.0 y }
+ { 0.0 0.0 1.0 z }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
+: >scale-factors ( number/sequence -- x y z )
+ dup number? [ dup dup ] [ first3 ] if ;
+
+:: scale-matrix3 ( factors -- matrix )
+ factors >scale-factors :> z :> y :> x
+ {
+ { x 0.0 0.0 }
+ { 0.0 y 0.0 }
+ { 0.0 0.0 z }
+ } ;
+
+:: scale-matrix4 ( factors -- matrix )
+ factors >scale-factors :> z :> y :> x
+ {
+ { x 0.0 0.0 0.0 }
+ { 0.0 y 0.0 0.0 }
+ { 0.0 0.0 z 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
+: ortho-matrix4 ( dim -- matrix )
+ [ recip ] map scale-matrix4 ;
+
+:: frustum-matrix4 ( xy-dim near far -- matrix )
+ xy-dim first2 :> y :> x
+ near x /f :> xf
+ near y /f :> yf
+ near far + near far - /f :> zf
+ 2 near far * * near far - /f :> wf
+
+ {
+ { xf 0.0 0.0 0.0 }
+ { 0.0 yf 0.0 0.0 }
+ { 0.0 0.0 zf wf }
+ { 0.0 0.0 -1.0 0.0 }
+ } ;
+
+:: skew-matrix4 ( theta -- matrix )
+ theta tan :> zf
+
+ {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 1.0 0.0 0.0 }
+ { 0.0 zf 1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
! Matrix operations
: mneg ( m -- m ) [ vneg ] map ;
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
+
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file
: (gen-gl-object) ( quot -- id )
[ 1 0 <uint> ] dip keep *uint ; inline
-: gen-gl-buffer ( -- id )
- [ glGenBuffers ] (gen-gl-object) ;
-
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
+: gen-gl-buffer ( -- id )
+ [ glGenBuffers ] (gen-gl-object) ;
+
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
GL_ARRAY_BUFFER swap _ with-gl-buffer
] with-gl-buffer ; inline
+: gen-vertex-array ( -- id )
+ [ glGenVertexArrays ] (gen-gl-object) ;
+
+: delete-vertex-array ( id -- )
+ [ glDeleteVertexArrays ] (delete-gl-object) ;
+
+:: with-vertex-array ( id quot -- )
+ id glBindVertexArray
+ quot [ 0 glBindVertexArray ] [ ] cleanup ; inline
+
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [
[
[ "Hi" ] [ "Hi" present ] unit-test
[ "+" ] [ \ + present ] unit-test
[ "kernel" ] [ "kernel" vocab present ] unit-test
-[ ] [ all-vocabs-seq [ present ] map drop ] unit-test
\ No newline at end of file
+[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test
\ No newline at end of file
USE: specialized-arrays.functor
IN: specialized-arrays.alien
-<< "void*" define-array >>
\ No newline at end of file
+<< "void*" define-array >>
+<< "ptrdiff_t" define-array >>
--- /dev/null
+
+: spill-integer-base ( -- n )
+ stack-frame get spill-counts>> double-float-regs swap at
+ double-float-regs reg-size * ;
+
+: spill-integer@ ( n -- offset )
+ cells spill-integer-base + param@ ;
+
+: spill-float@ ( n -- offset )
+ double-float-regs reg-size * param@ ;
+
+: (stack-frame-size) ( stack-frame -- n )
+ [
+ {
+ [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+ [ gc-roots>> cells ]
+ [ params>> ]
+ [ return>> ]
+ } cleave
+ ] sum-outputs ;
\ No newline at end of file
: thread-registered? ( thread -- ? )
id>> threads key? ;
+ERROR: already-stopped thread ;
+
: check-unregistered ( thread -- thread )
- dup thread-registered?
- [ "Thread already stopped" throw ] when ;
+ dup thread-registered? [ already-stopped ] when ;
+
+ERROR: not-running thread ;
: check-registered ( thread -- thread )
- dup thread-registered?
- [ "Thread is not running" throw ] unless ;
+ dup thread-registered? [ not-running ] unless ;
<PRIVATE
[ ] [ M\ string blah-generic watch ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test
+
+! See how well watch interacts with optimizations.
+GENERIC: my-generic ( a -- b )
+M: object my-generic ;
+
+\ my-generic watch
+
+: some-code ( -- )
+ f my-generic drop ;
+
+[ ] [ some-code ] unit-test
\ No newline at end of file
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry tools.continuations ;
+tools.time generic inspector fry tools.continuations
+locals generalizations macros ;
IN: tools.annotations
GENERIC: reset ( word -- )
<PRIVATE
-: stack-values ( names -- alist )
- [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
-
-: trace-message ( word quot str -- )
- "--- " write write bl over .
- [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
- [ simple-table. ] unless-empty flush ; inline
+:: trace-quot ( word effect quot str -- quot' )
+ effect quot call :> values
+ values length :> n
+ [
+ "--- " write str write bl word .
+ n ndup n narray values swap zip simple-table.
+ flush
+ ] ; inline
-: entering ( str -- ) [ in>> ] "Entering" trace-message ;
+MACRO: entering ( word -- quot )
+ dup stack-effect [ in>> ] "Entering" trace-quot ;
-: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
+MACRO: leaving ( word -- quot )
+ dup stack-effect [ out>> ] "Leaving" trace-quot ;
: (watch) ( word def -- def )
over '[ _ entering @ _ leaving ] ;
all-words name-completions ;
: vocabs-matching ( str -- seq )
- all-vocabs-seq name-completions ;
+ all-vocabs-recursive no-roots no-prefixes name-completions ;
: chars-matching ( str -- seq )
name-map keys dup zip completions ;
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
-: with-gl-context ( handle quot -- )
- '[ select-gl-context @ ]
- [ flush-gl-context gl-error ] bi ; inline
-
HOOK: (with-ui) ui-backend ( quot -- )
HOOK: (grab-input) ui-backend ( handle -- )
] [ drop ] if ;
: end-selection ( pane -- )
- f >>selecting?
- hand-moved?
+ dup selecting?>> hand-moved? or
+ [ f >>selecting? ] dip
[ [ com-copy-selection ] [ request-focus ] bi ]
[ [ relayout-1 ] [ focus-input ] bi ]
if ;
if ;
: row-action? ( table -- ? )
- [ [ mouse-row ] keep valid-line? ]
- [ single-click?>> hand-click# get 2 = or ] bi and ;
+ single-click?>> hand-click# get 2 = or ;
<PRIVATE
: table-button-up ( table -- )
- dup row-action? [ row-action ] [ update-selected-value ] if ;
+ dup [ mouse-row ] keep valid-line? [
+ dup row-action? [ row-action ] [ update-selected-value ] if
+ ] [ drop ] if ;
PRIVATE>
USING: ui.gadgets ui.render ui.text ui.text.private
ui.gestures ui.backend help.markup help.syntax
-models opengl sequences strings ;
+models opengl sequences strings destructors ;
IN: ui.gadgets.worlds
HELP: user-input
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
-HELP: select-gl-context
-{ $values { "handle" "a backend-specific handle" } }
+HELP: context-world
+{ $var-description "Holds the " { $link world } " whose OpenGL context was most recently made active by " { $link set-gl-context } "." } ;
+
+HELP: set-gl-context
+{ $values { "world" world } }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
+HELP: window-resource
+{ $values { "resource" disposable } { "resource" disposable } }
+{ $description "Marks " { $snippet "resource" } " to be destroyed with " { $link dispose } " when the window with the currently active OpenGL context (set by " { $link set-gl-context } ") is closed. " { $snippet "resource" } " is left unmodified at the top of the stack." } ;
+
HELP: flush-gl-context
{ $values { "handle" "a backend-specific handle" } }
{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
text-handle handle images
window-loc
pixel-format-attributes
- window-controls ;
+ window-controls
+ window-resources ;
TUPLE: world-attributes
{ world-class initial: world }
'[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
] [ 2drop ] if ;
+SYMBOL: context-world
+
+: window-resource ( resource -- resource )
+ dup context-world get-global window-resources>> push ;
+
+: set-gl-context ( world -- )
+ [ context-world set-global ]
+ [ handle>> select-gl-context ] bi ;
+
+: with-gl-context ( world quot -- )
+ '[ set-gl-context @ ]
+ [ handle>> flush-gl-context gl-error ] bi ; inline
+
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup
- [ handle>> select-gl-context ] [ no-world-found ] if ;
+ [ set-gl-context ] [ no-world-found ] if ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
t >>root?
f >>active?
{ 0 0 } >>window-loc
- f >>grab-input? ;
+ f >>grab-input?
+ V{ } clone >>window-resources ;
: apply-world-attributes ( world attributes -- world )
{
[ call-next-method ]
[
dup handle>>
- [ select-gl-context resize-world ]
- [ drop ] if*
+ [ [ set-gl-context ] [ resize-world ] bi ]
+ [ drop ] if
] bi ;
GENERIC: draw-world* ( world -- )
dup draw-world? [
dup world [
[
- dup handle>> [ draw-world* ] with-gl-context
+ dup [ draw-world* ] with-gl-context
flush-layout-cache-hook get call( -- )
] [
over <world-error> ui-error
M: word-completion row-color
[ vocabulary>> ] [ manifest>> ] bi* {
+ { [ dup not ] [ COLOR: black ] }
{ [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
{ [ over ".private" tail? ] [ COLOR: dark-red ] }
[ COLOR: dark-gray ]
[ ] [ "h" get history-recall-previous ] unit-test
[ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "aaa" "d" get set-doc-string ] unit-test
+[ T{ input f "aaa" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ ] [ " " "d" get set-doc-string ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+
<PRIVATE
+: (save-history) ( input index elements -- )
+ 2dup length > [
+ [ [ T{ input f "" } ] dip push ] keep
+ (save-history)
+ ] [ set-nth ] if ;
+
: save-history ( history -- )
[ document>> doc-string ] keep
- '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+ '[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
unless-empty ;
: update-document ( history -- )
} define-command-map
tool "common" f {
- { T{ key-down f { A+ } "s" } save }
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
: set-up-window ( world -- )
{
- [ handle>> select-gl-context ]
+ [ set-gl-context ]
[ [ title>> ] keep set-title ]
[ begin-world ]
[ resize-world ]
: (ungraft-world) ( world -- )
{
- [ handle>> select-gl-context ]
+ [ set-gl-context ]
[ text-handle>> [ dispose ] when* ]
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
+ [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
} cleave ;
M: world ungraft*
"The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
$nl "Operations for graphemes:"
{ $subsection first-grapheme }
+{ $subsection first-grapheme-from }
{ $subsection last-grapheme }
+{ $subsection last-grapheme-from }
{ $subsection >graphemes }
{ $subsection string-reverse }
"Operations on words:"
{ $subsection first-word }
+{ $subsection first-word-from }
+{ $subsection last-word }
+{ $subsection last-word-from }
{ $subsection >words } ;
HELP: first-grapheme
{ $values { "str" string } { "i" "an index" } }
{ $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
+HELP: first-grapheme-from
+{ $values { "start" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the length of the first grapheme of the string, starting from the given index. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
+
+HELP: last-grapheme-from
+{ $values { "end" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the index of the start of the last grapheme of the string, starting from the given index. This can be used to traverse the graphemes of a string backwards." } ;
+
HELP: >graphemes
{ $values { "str" string } { "graphemes" "an array of strings" } }
{ $description "Divides a string into a sequence of individual graphemes." } ;
HELP: first-word
{ $values { "str" string } { "i" "index" } }
-{ $description "Finds the length of the first word in the string." } ;
+{ $description "Finds the index of the end of the first word in the string." } ;
+
+HELP: last-word
+{ $values { "str" string } { "i" "index" } }
+{ $description "Finds the index of the beginning of the last word in the string." } ;
+
+HELP: first-word-from
+{ $values { "start" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the end of the first word in the string, starting from the given index." } ;
+
+HELP: last-word-from
+{ $values { "end" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the start of the word that the index is contained in." } ;
HELP: >words
{ $values { "str" string } { "words" "an array of strings" } }
[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
+[ 4 ] [ 2 "what am I saying" first-word-from ] unit-test
+[ 0 ] [ 2 "what am I saying" last-word-from ] unit-test
+[ 16 ] [ 11 "what am I saying" first-word-from ] unit-test
+[ 10 ] [ 11 "what am I saying" last-word-from ] unit-test
+
: grapheme-break-test ( -- filename )
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
word-break-next nip
]
} 2|| ;
+
+: first-word-from ( start str -- i )
+ over tail-slice first-word + ;
+
+: last-word ( str -- i )
+ [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+
+: last-word-from ( end str -- i )
+ swap head-slice last-word ;
: reset-cache ( -- )
root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized
- \ all-vocabs-seq reset-memoized
+ \ all-vocabs-recursive reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;
"Loading vocabulary hierarchies:"\r
{ $subsection load }\r
{ $subsection load-all }\r
-"Getting all vocabularies on disk:"\r
+"Getting all vocabularies from disk:"\r
{ $subsection all-vocabs }\r
-{ $subsection all-vocabs-seq }\r
-"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"\r
+{ $subsection all-vocabs-recursive }\r
+"Getting all vocabularies from disk whose names which match a string prefix:"\r
+{ $subsection child-vocabs }\r
+{ $subsection child-vocabs-recursive }\r
+"Words for modifying output:"\r
+{ $subsection no-roots }\r
+{ $subsection no-prefixes }\r
+"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"\r
{ $subsection all-tags }\r
{ $subsection all-authors } ;\r
\r
ABOUT: "vocabs.hierarchy"\r
\r
-HELP: all-vocabs\r
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
-\r
HELP: load\r
{ $values { "prefix" string } }\r
{ $description "Load all vocabularies that match the provided prefix." }\r
HELP: load-all\r
{ $description "Load all vocabularies in the source tree." } ;\r
\r
-HELP: all-vocabs-under\r
-{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }\r
-{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;\r
! Copyright (C) 2007, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays assocs combinators.short-circuit fry\r
+USING: accessors arrays assocs combinators.short-circuit fry\r
io.directories io.files io.files.info io.pathnames kernel make\r
memoize namespaces sequences sorting splitting vocabs sets\r
vocabs.loader vocabs.metadata vocabs.errors ;\r
+RENAME: child-vocabs vocabs => vocabs:child-vocabs\r
IN: vocabs.hierarchy\r
\r
+TUPLE: vocab-prefix name ;\r
+\r
+C: <vocab-prefix> vocab-prefix\r
+\r
+M: vocab-prefix vocab-name name>> ;\r
+\r
<PRIVATE\r
\r
: vocab-subdirs ( dir -- dirs )\r
] filter\r
] with-directory-files natural-sort ;\r
\r
-: (all-child-vocabs) ( root name -- vocabs )\r
- [\r
- vocab-dir append-path dup exists?\r
- [ vocab-subdirs ] [ drop { } ] if\r
- ] keep\r
- [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;\r
-\r
: vocab-dir? ( root name -- ? )\r
over\r
[ ".factor" vocab-dir+ append-path exists? ]\r
[ 2drop f ]\r
if ;\r
\r
-: vocabs-in-dir ( root name -- )\r
- dupd (all-child-vocabs) [\r
- 2dup vocab-dir? [ dup >vocab-link , ] when\r
- vocabs-in-dir\r
- ] with each ;\r
+: (child-vocabs) ( root prefix -- vocabs )\r
+ [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
+ [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]\r
+ [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]\r
+ 2tri ;\r
\r
-PRIVATE>\r
+: ((child-vocabs-recursive)) ( root name -- )\r
+ dupd vocab-name (child-vocabs)\r
+ [ dup , ((child-vocabs-recursive)) ] with each ;\r
\r
-: all-vocabs ( -- assoc )\r
- vocab-roots get [\r
- dup [ "" vocabs-in-dir ] { } make\r
- ] { } map>assoc ;\r
-\r
-: all-vocabs-under ( prefix -- vocabs )\r
- [\r
- [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each\r
- ] { } make ;\r
+: (child-vocabs-recursive) ( root name -- seq )\r
+ [ ((child-vocabs-recursive)) ] { } make ;\r
\r
-MEMO: all-vocabs-seq ( -- seq )\r
- "" all-vocabs-under ;\r
+: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;\r
\r
-<PRIVATE\r
+: one-level-only? ( name prefix -- ? )\r
+ ?head [ "." split1 nip not ] dip and ;\r
\r
: unrooted-child-vocabs ( prefix -- seq )\r
+ [ vocabs no-rooted ] dip\r
dup empty? [ CHAR: . suffix ] unless\r
- vocabs\r
- [ find-vocab-root not ] filter\r
- [\r
- vocab-name swap ?head CHAR: . rot member? not and\r
- ] with filter\r
- [ vocab ] map ;\r
+ '[ vocab-name _ one-level-only? ] filter ;\r
+\r
+: unrooted-child-vocabs-recursive ( prefix -- seq )\r
+ vocabs:child-vocabs no-rooted ;\r
\r
PRIVATE>\r
\r
-: all-child-vocabs ( prefix -- assoc )\r
- vocab-roots get [\r
- dup pick (all-child-vocabs) [ >vocab-link ] map\r
- ] { } map>assoc\r
- swap unrooted-child-vocabs f swap 2array suffix ;\r
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;\r
\r
-: all-child-vocabs-seq ( prefix -- assoc )\r
- vocab-roots get swap '[\r
- dup _ (all-child-vocabs)\r
- [ vocab-dir? ] with filter\r
- ] map concat ;\r
+: convert-prefixes ( seq -- seq' )\r
+ [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;\r
+\r
+: remove-redundant-prefixes ( seq -- seq' )\r
+ #! Hack.\r
+ [ vocab-prefix? ] partition\r
+ [\r
+ [ vocab-name ] map unique\r
+ '[ name>> _ key? not ] filter\r
+ convert-prefixes\r
+ ] keep\r
+ append ;\r
+\r
+: no-roots ( assoc -- seq ) values concat ;\r
+\r
+: child-vocabs ( prefix -- assoc )\r
+ [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
+ [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
+ bi suffix ;\r
+\r
+: all-vocabs ( -- assoc )\r
+ "" child-vocabs ;\r
+\r
+: child-vocabs-recursive ( prefix -- assoc )\r
+ [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
+ [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
+ bi suffix ;\r
+\r
+MEMO: all-vocabs-recursive ( -- assoc )\r
+ "" child-vocabs-recursive ;\r
+\r
+: all-vocab-names ( -- seq )\r
+ all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
+\r
+: child-vocab-names ( prefix -- seq )\r
+ child-vocabs no-roots no-prefixes [ vocab-name ] map ;\r
\r
<PRIVATE\r
\r
: filter-unportable ( seq -- seq' )\r
[ vocab-name unportable? not ] filter ;\r
\r
+: collect-vocabs ( quot -- seq )\r
+ [ all-vocabs-recursive no-roots no-prefixes ] dip\r
+ gather natural-sort ; inline\r
+\r
PRIVATE>\r
\r
: (load) ( prefix -- failures )\r
- all-vocabs-under\r
+ child-vocabs-recursive no-roots no-prefixes\r
filter-unportable\r
require-all ;\r
\r
: load-all ( -- )\r
"" load ;\r
\r
-MEMO: all-tags ( -- seq )\r
- all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
\r
-MEMO: all-authors ( -- seq )\r
- all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
+
+[ "" ] [ "" 10 wrap-string ] unit-test
+[ "Hello" ] [ "\nHello\n" 10 wrap-string ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: wrap tools.test ;
+
+[ { } ] [ { } 10 10 wrap ] unit-test
[
line-ideal set
line-max set
- initialize
- [ wrap-step ] reduce
- min-cost
- post-process
+ [ { } ] [
+ initialize
+ [ wrap-step ] reduce
+ min-cost
+ post-process
+ ] if-empty
] with-scope ;
PRIVATE>
: run-benchmark ( vocab -- )
- [ "=== " write vocab-name print flush ] [
+ [ "=== " write print flush ] [
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
[
V{ } clone timings set
V{ } clone errors set
- "benchmark" all-child-vocabs-seq
+ "benchmark" child-vocab-names
[ run-benchmark ] each
timings get
errors get
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators kernel locals math
+math.ranges memoize sequences strings hashtables
+math.parser grouping ;
+IN: benchmark.hashtables
+
+MEMO: strings ( -- str )
+ 1 100 [a,b] 1 [ + ] accumulate nip [ number>string ] map ;
+
+:: add-delete-mix ( hash keys -- )
+ keys [| k |
+ 0 k hash set-at
+ k hash delete-at
+ ] each
+
+ keys [
+ 0 swap hash set-at
+ ] each
+
+ keys [
+ hash delete-at
+ ] each ;
+
+:: store-lookup-mix ( hash keys -- )
+ keys [
+ 0 swap hash set-at
+ ] each
+
+ keys [
+ hash at
+ ] map drop
+
+ keys [
+ hash [ 1 + ] change-at
+ ] each ;
+
+: string-mix ( hash -- )
+ strings
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi ;
+
+TUPLE: collision value ;
+
+M: collision hashcode* value>> hashcode* 15 bitand ;
+
+: collision-mix ( hash -- )
+ strings 30 head [ collision boa ] map
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi ;
+
+: small-mix ( hash -- )
+ strings 10 group [
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi
+ ] with each ;
+
+: hashtable-benchmark ( -- )
+ H{ } clone
+ 10000 [
+ dup {
+ [ small-mix ]
+ [ clear-assoc ]
+ [ string-mix ]
+ [ clear-assoc ]
+ [ collision-mix ]
+ [ clear-assoc ]
+ } cleave
+ ] times
+ drop ;
+
+MAIN: hashtable-benchmark
\ No newline at end of file
--- /dev/null
+Matthew Willis
--- /dev/null
+USING: central destructors help.markup help.syntax ;
+
+HELP: CENTRAL:
+{ $description
+ "This parsing word defines a pair of words useful for "
+ "implementing the \"central\" pattern: " { $snippet "symbol" } " and "
+ { $snippet "with-symbol" } ". This is a middle ground between excessive "
+ "stack manipulation and full-out locals, meant to solve the case where "
+ "one object is operated on by several related words."
+} ;
+
+HELP: DISPOSABLE-CENTRAL:
+{ $description
+ "Like " { $link POSTPONE: CENTRAL: } ", but generates " { $snippet "with-" }
+ " words that are wrapped in a " { $link with-disposal } "."
+} ;
\ No newline at end of file
--- /dev/null
+USING: accessors central destructors kernel math tools.test ;
+
+IN: scratchpad
+
+CENTRAL: test-central
+
+[ 3 ] [ 3 [ test-central ] with-test-central ] unit-test
+
+TUPLE: test-disp-cent value disposed ;
+
+! A phony destructor that adds 1 to the value so we can make sure it got called.
+M: test-disp-cent dispose* dup value>> 1+ >>value drop ;
+
+DISPOSABLE-CENTRAL: t-d-c
+
+: test-t-d-c ( -- n )
+ test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ;
+
+[ 4 ] [ test-t-d-c ] unit-test
\ No newline at end of file
--- /dev/null
+USING: destructors kernel lexer namespaces parser sequences words ;
+
+IN: central
+
+: define-central-getter ( word -- )
+ dup [ get ] curry (( -- obj )) define-declared ;
+
+: define-centrals ( str -- getter setter )
+ [ create-in dup define-central-getter ]
+ [ "with-" prepend create-in dup make-inline ] bi ;
+
+: central-setter-def ( word with-word -- with-word quot )
+ [ with-variable ] with ;
+
+: disposable-setter-def ( word with-word -- with-word quot )
+ [ pick [ drop with-variable ] with-disposal ] with ;
+
+: declare-central ( with-word quot -- ) (( object quot -- )) define-declared ;
+
+: define-central ( word-name -- )
+ define-centrals central-setter-def declare-central ;
+
+: define-disposable-central ( word-name -- )
+ define-centrals disposable-setter-def declare-central ;
+
+SYNTAX: CENTRAL: ( -- ) scan define-central ;
+
+SYNTAX: DISPOSABLE-CENTRAL: ( -- ) scan define-disposable-central ;
\ No newline at end of file
--- /dev/null
+extensions
parser prettyprint sequences summary help.vocabs
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
listener ;
-
+FROM: vocabs.hierarchy => child-vocabs ;
IN: fuel.help
<PRIVATE
[ fuel-vocab-help-table ] bi*
[ 2array ] [ drop f ] if*
] if-empty
- ] { } assoc>map [ ] filter ;
+ ] { } assoc>map sift ;
: fuel-vocab-children-help ( name -- element )
- all-child-vocabs fuel-vocab-list ; inline
+ child-vocabs fuel-vocab-list ; inline
: fuel-vocab-describe-words ( name -- element )
[ words. ] with-string-writer \ describe-words swap 2array ; inline
: article-location ( name -- loc ) article loc>> get-loc ;
-: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ;
+: get-vocabs ( -- seq ) all-vocab-names ;
: get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ;
[ -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
--- /dev/null
+Matthew Willis
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.libraries alien.syntax ;
+
+IN: llvm.core
+
+<<
+
+"LLVMSystem" "/usr/local/lib/libLLVMSystem.dylib" "cdecl" add-library
+
+"LLVMSupport" "/usr/local/lib/libLLVMSupport.dylib" "cdecl" add-library
+
+"LLVMCore" "/usr/local/lib/libLLVMCore.dylib" "cdecl" add-library
+
+"LLVMBitReader" "/usr/local/lib/libLLVMBitReader.dylib" "cdecl" add-library
+
+>>
+
+! llvm-c/Core.h
+
+LIBRARY: LLVMCore
+
+TYPEDEF: uint unsigned
+TYPEDEF: unsigned enum
+
+CONSTANT: LLVMZExtAttribute BIN: 1
+CONSTANT: LLVMSExtAttribute BIN: 10
+CONSTANT: LLVMNoReturnAttribute BIN: 100
+CONSTANT: LLVMInRegAttribute BIN: 1000
+CONSTANT: LLVMStructRetAttribute BIN: 10000
+CONSTANT: LLVMNoUnwindAttribute BIN: 100000
+CONSTANT: LLVMNoAliasAttribute BIN: 1000000
+CONSTANT: LLVMByValAttribute BIN: 10000000
+CONSTANT: LLVMNestAttribute BIN: 100000000
+CONSTANT: LLVMReadNoneAttribute BIN: 1000000000
+CONSTANT: LLVMReadOnlyAttribute BIN: 10000000000
+TYPEDEF: enum LLVMAttribute;
+
+C-ENUM:
+ LLVMVoidTypeKind
+ LLVMFloatTypeKind
+ LLVMDoubleTypeKind
+ LLVMX86_FP80TypeKind
+ LLVMFP128TypeKind
+ LLVMPPC_FP128TypeKind
+ LLVMLabelTypeKind
+ LLVMMetadataTypeKind
+ LLVMIntegerTypeKind
+ LLVMFunctionTypeKind
+ LLVMStructTypeKind
+ LLVMArrayTypeKind
+ LLVMPointerTypeKind
+ LLVMOpaqueTypeKind
+ LLVMVectorTypeKind ;
+TYPEDEF: enum LLVMTypeKind
+
+C-ENUM:
+ LLVMExternalLinkage
+ LLVMLinkOnceLinkage
+ LLVMWeakLinkage
+ LLVMAppendingLinkage
+ LLVMInternalLinkage
+ LLVMDLLImportLinkage
+ LLVMDLLExportLinkage
+ LLVMExternalWeakLinkage
+ LLVMGhostLinkage ;
+TYPEDEF: enum LLVMLinkage
+
+C-ENUM:
+ LLVMDefaultVisibility
+ LLVMHiddenVisibility
+ LLVMProtectedVisibility ;
+TYPEDEF: enum LLVMVisibility
+
+CONSTANT: LLVMCCallConv 0
+CONSTANT: LLVMFastCallConv 8
+CONSTANT: LLVMColdCallConv 9
+CONSTANT: LLVMX86StdcallCallConv 64
+CONSTANT: LLVMX86FastcallCallConv 65
+TYPEDEF: enum LLVMCallConv
+
+CONSTANT: LLVMIntEQ 32
+CONSTANT: LLVMIntNE 33
+CONSTANT: LLVMIntUGT 34
+CONSTANT: LLVMIntUGE 35
+CONSTANT: LLVMIntULT 36
+CONSTANT: LLVMIntULE 37
+CONSTANT: LLVMIntSGT 38
+CONSTANT: LLVMIntSGE 39
+CONSTANT: LLVMIntSLT 40
+CONSTANT: LLVMIntSLE 41
+TYPEDEF: enum LLVMIntPredicate
+
+C-ENUM:
+ LLVMRealPredicateFalse
+ LLVMRealOEQ
+ LLVMRealOGT
+ LLVMRealOGE
+ LLVMRealOLT
+ LLVMRealOLE
+ LLVMRealONE
+ LLVMRealORD
+ LLVMRealUNO
+ LLVMRealUEQ
+ LLVMRealUGT
+ LLVMRealUGE
+ LLVMRealULT
+ LLVMRealULE
+ LLVMRealUNE
+ LLVMRealPredicateTrue ;
+TYPEDEF: enum LLVMRealPredicate
+
+! Opaque Types
+
+TYPEDEF: void* LLVMModuleRef
+
+TYPEDEF: void* LLVMPassManagerRef
+
+TYPEDEF: void* LLVMModuleProviderRef
+
+TYPEDEF: void* LLVMTypeRef
+
+TYPEDEF: void* LLVMTypeHandleRef
+
+TYPEDEF: void* LLVMValueRef
+
+TYPEDEF: void* LLVMBasicBlockRef
+
+TYPEDEF: void* LLVMBuilderRef
+
+TYPEDEF: void* LLVMMemoryBufferRef
+
+! Functions
+
+FUNCTION: void LLVMDisposeMessage ( char* Message ) ;
+
+FUNCTION: LLVMModuleRef LLVMModuleCreateWithName ( char* ModuleID ) ;
+
+FUNCTION: int LLVMAddTypeName ( LLVMModuleRef M, char* Name, LLVMTypeRef Ty ) ;
+
+FUNCTION: void LLVMDisposeModule ( LLVMModuleRef M ) ;
+
+FUNCTION: void LLVMDumpModule ( LLVMModuleRef M ) ;
+
+FUNCTION: LLVMModuleProviderRef
+LLVMCreateModuleProviderForExistingModule ( LLVMModuleRef M ) ;
+
+FUNCTION: void LLVMDisposeModuleProvider ( LLVMModuleProviderRef MP ) ;
+
+! Types
+
+! LLVM types conform to the following hierarchy:
+!
+! types:
+! integer type
+! real type
+! function type
+! sequence types:
+! array type
+! pointer type
+! vector type
+! void type
+! label type
+! opaque type
+
+! See llvm::LLVMTypeKind::getTypeID.
+FUNCTION: LLVMTypeKind LLVMGetTypeKind ( LLVMTypeRef Ty ) ;
+
+! Operations on integer types
+FUNCTION: LLVMTypeRef LLVMInt1Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt8Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt16Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt32Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt64Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ;
+FUNCTION: unsigned LLVMGetIntTypeWidth ( LLVMTypeRef IntegerTy ) ;
+
+! Operations on real types
+FUNCTION: LLVMTypeRef LLVMFloatType ( ) ;
+FUNCTION: LLVMTypeRef LLVMDoubleType ( ) ;
+FUNCTION: LLVMTypeRef LLVMX86FP80Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMFP128Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMPPCFP128Type ( ) ;
+
+! Operations on function types
+FUNCTION: LLVMTypeRef
+LLVMFunctionType ( LLVMTypeRef ReturnType, LLVMTypeRef* ParamTypes, unsigned ParamCount, int IsVarArg ) ;
+FUNCTION: int LLVMIsFunctionVarArg ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: LLVMTypeRef LLVMGetReturnType ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: unsigned LLVMCountParamTypes ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: void LLVMGetParamTypes ( LLVMTypeRef FunctionTy, LLVMTypeRef* Dest ) ;
+
+! Operations on struct types
+FUNCTION: LLVMTypeRef
+LLVMStructType ( LLVMTypeRef* ElementTypes, unsigned ElementCount, int Packed ) ;
+FUNCTION: unsigned LLVMCountStructElementTypes ( LLVMTypeRef StructTy ) ;
+FUNCTION: void LLVMGetStructElementTypes ( LLVMTypeRef StructTy, LLVMTypeRef* Dest ) ;
+FUNCTION: int LLVMIsPackedStruct ( LLVMTypeRef StructTy ) ;
+
+! Operations on array, pointer, and vector types (sequence types)
+FUNCTION: LLVMTypeRef LLVMArrayType ( LLVMTypeRef ElementType, unsigned ElementCount ) ;
+FUNCTION: LLVMTypeRef LLVMPointerType ( LLVMTypeRef ElementType, unsigned AddressSpace ) ;
+FUNCTION: LLVMTypeRef LLVMVectorType ( LLVMTypeRef ElementType, unsigned ElementCount ) ;
+
+FUNCTION: LLVMTypeRef LLVMGetElementType ( LLVMTypeRef Ty ) ;
+FUNCTION: unsigned LLVMGetArrayLength ( LLVMTypeRef ArrayTy ) ;
+FUNCTION: unsigned LLVMGetPointerAddressSpace ( LLVMTypeRef PointerTy ) ;
+FUNCTION: unsigned LLVMGetVectorSize ( LLVMTypeRef VectorTy ) ;
+
+! Operations on other types
+FUNCTION: LLVMTypeRef LLVMVoidType ( ) ;
+FUNCTION: LLVMTypeRef LLVMLabelType ( ) ;
+FUNCTION: LLVMTypeRef LLVMOpaqueType ( ) ;
+
+! Operations on type handles
+FUNCTION: LLVMTypeHandleRef LLVMCreateTypeHandle ( LLVMTypeRef PotentiallyAbstractTy ) ;
+FUNCTION: void LLVMRefineType ( LLVMTypeRef AbstractTy, LLVMTypeRef ConcreteTy ) ;
+FUNCTION: LLVMTypeRef LLVMResolveTypeHandle ( LLVMTypeHandleRef TypeHandle ) ;
+FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle ) ;
+
+! Types end
+
+FUNCTION: unsigned LLVMCountParams ( LLVMValueRef Fn ) ;
+
+FUNCTION: void LLVMGetParams ( LLVMValueRef Fn, LLVMValueRef* Params ) ;
+
+FUNCTION: LLVMValueRef
+LLVMAddFunction ( LLVMModuleRef M, char* Name, LLVMTypeRef FunctionTy ) ;
+
+FUNCTION: LLVMValueRef LLVMGetFirstFunction ( LLVMModuleRef M ) ;
+
+FUNCTION: LLVMValueRef LLVMGetNextFunction ( LLVMValueRef Fn ) ;
+
+FUNCTION: unsigned LLVMGetFunctionCallConv ( LLVMValueRef Fn ) ;
+
+FUNCTION: void LLVMSetFunctionCallConv ( LLVMValueRef Fn, unsigned CC ) ;
+
+FUNCTION: LLVMBasicBlockRef
+LLVMAppendBasicBlock ( LLVMValueRef Fn, char* Name ) ;
+
+FUNCTION: LLVMValueRef LLVMGetBasicBlockParent ( LLVMBasicBlockRef BB ) ;
+
+! Values
+
+FUNCTION: LLVMTypeRef LLVMTypeOf ( LLVMValueRef Val ) ;
+FUNCTION: char* LLVMGetValueName ( LLVMValueRef Val ) ;
+FUNCTION: void LLVMSetValueName ( LLVMValueRef Val, char* Name ) ;
+FUNCTION: void LLVMDumpValue ( LLVMValueRef Val ) ;
+
+! Instruction Builders
+
+FUNCTION: LLVMBuilderRef LLVMCreateBuilder ( ) ;
+FUNCTION: void LLVMPositionBuilder
+( LLVMBuilderRef Builder, LLVMBasicBlockRef Block, LLVMValueRef Instr ) ;
+FUNCTION: void LLVMPositionBuilderBefore
+( LLVMBuilderRef Builder, LLVMValueRef Instr ) ;
+FUNCTION: void LLVMPositionBuilderAtEnd
+( LLVMBuilderRef Builder, LLVMBasicBlockRef Block ) ;
+FUNCTION: LLVMBasicBlockRef LLVMGetInsertBlock
+( LLVMBuilderRef Builder ) ;
+FUNCTION: void LLVMClearInsertionPosition
+( LLVMBuilderRef Builder ) ;
+FUNCTION: void LLVMInsertIntoBuilder
+( LLVMBuilderRef Builder, LLVMValueRef Instr ) ;
+FUNCTION: void LLVMDisposeBuilder
+( LLVMBuilderRef Builder ) ;
+
+! IB Terminators
+
+FUNCTION: LLVMValueRef LLVMBuildRetVoid
+( LLVMBuilderRef Builder ) ;
+FUNCTION: LLVMValueRef LLVMBuildRet
+( LLVMBuilderRef Builder, LLVMValueRef V ) ;
+FUNCTION: LLVMValueRef LLVMBuildBr
+( LLVMBuilderRef Builder, LLVMBasicBlockRef Dest ) ;
+FUNCTION: LLVMValueRef LLVMBuildCondBr
+( LLVMBuilderRef Builder, LLVMValueRef If, LLVMBasicBlockRef Then, LLVMBasicBlockRef Else ) ;
+FUNCTION: LLVMValueRef LLVMBuildSwitch
+( LLVMBuilderRef Builder, LLVMValueRef V, LLVMBasicBlockRef Else, unsigned NumCases ) ;
+FUNCTION: LLVMValueRef LLVMBuildInvoke
+( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef* Args, unsigned NumArgs,
+ LLVMBasicBlockRef Then, LLVMBasicBlockRef Catch, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildUnwind
+( LLVMBuilderRef Builder ) ;
+FUNCTION: LLVMValueRef LLVMBuildUnreachable
+( LLVMBuilderRef Builder ) ;
+
+! IB Add Case to Switch
+
+FUNCTION: void LLVMAddCase
+( LLVMValueRef Switch, LLVMValueRef OnVal, LLVMBasicBlockRef Dest ) ;
+
+! IB Arithmetic
+
+FUNCTION: LLVMValueRef LLVMBuildAdd
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSub
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildMul
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildUDiv
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSDiv
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFDiv
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildURem
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSRem
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFRem
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildShl
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildLShr
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildAShr
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildAnd
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildOr
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildXor
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildNeg
+( LLVMBuilderRef Builder, LLVMValueRef V, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildNot
+( LLVMBuilderRef Builder, LLVMValueRef V, char* Name ) ;
+
+! IB Memory
+
+FUNCTION: LLVMValueRef LLVMBuildMalloc
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildArrayMalloc
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, LLVMValueRef Val, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildAlloca
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildArrayAlloca
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, LLVMValueRef Val, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFree
+( LLVMBuilderRef Builder, LLVMValueRef PointerVal ) ;
+FUNCTION: LLVMValueRef LLVMBuildLoad
+( LLVMBuilderRef Builder, LLVMValueRef PointerVal, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildStore
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMValueRef Ptr ) ;
+FUNCTION: LLVMValueRef LLVMBuildGEP
+( LLVMBuilderRef B, LLVMValueRef Pointer, LLVMValueRef* Indices,
+ unsigned NumIndices, char* Name ) ;
+
+! IB Casts
+
+FUNCTION: LLVMValueRef LLVMBuildTrunc
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildZExt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSExt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPToUI
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPToSI
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildUIToFP
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSIToFP
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPTrunc
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPExt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildPtrToInt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildIntToPtr
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildBitCast
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+
+! IB Comparisons
+
+FUNCTION: LLVMValueRef LLVMBuildICmp
+( LLVMBuilderRef Builder, LLVMIntPredicate Op, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFCmp
+( LLVMBuilderRef Builder, LLVMRealPredicate Op, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+
+! IB Misc Instructions
+
+FUNCTION: LLVMValueRef LLVMBuildPhi
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildCall
+( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef* Args, unsigned NumArgs, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSelect
+( LLVMBuilderRef Builder, LLVMValueRef If, LLVMValueRef Then, LLVMValueRef Else, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildVAArg
+( LLVMBuilderRef Builder, LLVMValueRef List, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildExtractElement
+( LLVMBuilderRef Builder, LLVMValueRef VecVal, LLVMValueRef Index, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildInsertElement
+( LLVMBuilderRef Builder, LLVMValueRef VecVal, LLVMValueRef EltVal, LLVMValueRef Index, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildShuffleVector
+( LLVMBuilderRef Builder, LLVMValueRef V1, LLVMValueRef V2, LLVMValueRef Mask, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildExtractValue
+( LLVMBuilderRef Builder, LLVMValueRef AggVal, unsigned Index, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildInsertValue
+( LLVMBuilderRef Builder, LLVMValueRef AggVal, LLVMValueRef EltVal, unsigned Index, char* Name ) ;
+
+! Memory Buffers/Bit Reader
+
+FUNCTION: int LLVMCreateMemoryBufferWithContentsOfFile
+( char* Path, LLVMMemoryBufferRef* OutMemBuf, char** OutMessage ) ;
+
+FUNCTION: void LLVMDisposeMemoryBuffer ( LLVMMemoryBufferRef MemBuf ) ;
+
+LIBRARY: LLVMBitReader
+
+FUNCTION: int LLVMParseBitcode
+( LLVMMemoryBufferRef MemBuf, LLVMModuleRef* OutModule, char** OutMessage ) ;
+
+FUNCTION: int LLVMGetBitcodeModuleProvider
+( LLVMMemoryBufferRef MemBuf, LLVMModuleProviderRef* OutMP, char** OutMessage ) ;
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.libraries alien.syntax llvm.core ;
+IN: llvm.engine
+
+<<
+
+"LLVMExecutionEngine" "/usr/local/lib/libLLVMExecutionEngine.dylib" "cdecl" add-library
+
+"LLVMTarget" "/usr/local/lib/libLLVMTarget.dylib" "cdecl" add-library
+
+"LLVMAnalysis" "/usr/local/lib/libLLVMAnalysis.dylib" "cdecl" add-library
+
+"LLVMipa" "/usr/local/lib/libLLVMipa.dylib" "cdecl" add-library
+
+"LLVMTransformUtils" "/usr/local/lib/libLLVMTransformUtils.dylib" "cdecl" add-library
+
+"LLVMScalarOpts" "/usr/local/lib/libLLVMScalarOpts.dylib" "cdecl" add-library
+
+"LLVMCodeGen" "/usr/local/lib/libLLVMCodeGen.dylib" "cdecl" add-library
+
+"LLVMAsmPrinter" "/usr/local/lib/libLLVMAsmPrinter.dylib" "cdecl" add-library
+
+"LLVMSelectionDAG" "/usr/local/lib/libLLVMSelectionDAG.dylib" "cdecl" add-library
+
+"LLVMX86CodeGen" "/usr/local/lib/libLLVMX86CodeGen.dylib" "cdecl" add-library
+
+"LLVMJIT" "/usr/local/lib/libLLVMJIT.dylib" "cdecl" add-library
+
+"LLVMInterpreter.dylib" "/usr/local/lib/libLLVMInterpreter.dylib" "cdecl" add-library
+
+>>
+
+! llvm-c/ExecutionEngine.h
+
+LIBRARY: LLVMExecutionEngine
+
+TYPEDEF: void* LLVMGenericValueRef
+TYPEDEF: void* LLVMExecutionEngineRef
+
+FUNCTION: LLVMGenericValueRef LLVMCreateGenericValueOfInt
+( LLVMTypeRef Ty, ulonglong N, int IsSigned ) ;
+
+FUNCTION: ulonglong LLVMGenericValueToInt
+( LLVMGenericValueRef GenVal, int IsSigned ) ;
+
+FUNCTION: int LLVMCreateExecutionEngine
+( LLVMExecutionEngineRef *OutEE, LLVMModuleProviderRef MP, char** OutError ) ;
+
+FUNCTION: int LLVMCreateJITCompiler
+( LLVMExecutionEngineRef* OutJIT, LLVMModuleProviderRef MP, unsigned OptLevel, char** OutError ) ;
+
+FUNCTION: void LLVMDisposeExecutionEngine ( LLVMExecutionEngineRef EE ) ;
+
+FUNCTION: void LLVMFreeMachineCodeForFunction ( LLVMExecutionEngineRef EE, LLVMValueRef F ) ;
+
+FUNCTION: void LLVMAddModuleProvider ( LLVMExecutionEngineRef EE, LLVMModuleProviderRef MP ) ;
+
+FUNCTION: int LLVMRemoveModuleProvider
+( LLVMExecutionEngineRef EE, LLVMModuleProviderRef MP, LLVMModuleRef* OutMod, char** OutError ) ;
+
+FUNCTION: int LLVMFindFunction
+( LLVMExecutionEngineRef EE, char* Name, LLVMValueRef* OutFn ) ;
+
+FUNCTION: void* LLVMGetPointerToGlobal ( LLVMExecutionEngineRef EE, LLVMValueRef Global ) ;
+
+FUNCTION: LLVMGenericValueRef LLVMRunFunction
+( LLVMExecutionEngineRef EE, LLVMValueRef F, unsigned NumArgs, LLVMGenericValueRef* Args ) ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.llvm io.pathnames llvm.invoker llvm.reader tools.test ;
+
+[ 3 ] [
+ << "resource:extra/llvm/reader/add.bc" install-bc >> 1 2 add
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien arrays assocs compiler.units effects
+io.backend io.pathnames kernel llvm.core llvm.jit llvm.reader
+llvm.types make namespaces sequences specialized-arrays.alien
+vocabs words ;
+
+IN: llvm.invoker
+
+! get function name, ret type, param types and names
+
+! load module
+! iterate through functions in a module
+
+TUPLE: function name alien return params ;
+
+: params ( llvm-function -- param-list )
+ dup LLVMCountParams <void*-array>
+ [ LLVMGetParams ] keep >array
+ [ [ LLVMGetValueName ] [ LLVMTypeOf tref> ] bi 2array ] map ;
+
+: <function> ( LLVMValueRef -- function )
+ function new
+ over LLVMGetValueName >>name
+ over LLVMTypeOf tref> type>> return>> >>return
+ swap params >>params ;
+
+: (functions) ( llvm-function -- )
+ [ dup , LLVMGetNextFunction (functions) ] when* ;
+
+: functions ( llvm-module -- functions )
+ LLVMGetFirstFunction [ (functions) ] { } make [ <function> ] map ;
+
+: function-effect ( function -- effect )
+ [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi <effect> ;
+
+: install-function ( function -- )
+ dup name>> "alien.llvm" create-vocab drop
+ "alien.llvm" create swap
+ [
+ dup name>> function-pointer ,
+ dup return>> c-type ,
+ dup params>> [ second c-type ] map ,
+ "cdecl" , \ alien-indirect ,
+ ] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
+
+: install-module ( name -- )
+ thejit get mps>> at [
+ module>> functions [ install-function ] each
+ ] [ "no such module" throw ] if* ;
+
+: install-bc ( path -- )
+ [ normalize-path ] [ file-name ] bi
+ [ load-into-jit ] keep install-module ;
+
+<< "alien.llvm" create-vocab drop >>
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: destructors llvm.jit llvm.wrappers tools.test ;
+
+[ ] [ "test" <module> "test" add-module "test" remove-module ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax assocs destructors
+kernel llvm.core llvm.engine llvm.wrappers namespaces ;
+
+IN: llvm.jit
+
+SYMBOL: thejit
+
+TUPLE: jit ee mps ;
+
+: empty-engine ( -- engine )
+ "initial-module" <module> <provider> <engine> ;
+
+: <jit> ( -- jit )
+ jit new empty-engine >>ee H{ } clone >>mps ;
+
+: (remove-functions) ( function -- )
+ thejit get ee>> value>> over LLVMFreeMachineCodeForFunction
+ LLVMGetNextFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
+
+: remove-functions ( module -- )
+ ! free machine code for each function in module
+ LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
+
+: remove-provider ( provider -- )
+ thejit get ee>> value>> swap value>> f <void*> f <void*>
+ [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
+ *void* module new swap >>value
+ [ value>> remove-functions ] with-disposal ;
+
+: remove-module ( name -- )
+ dup thejit get mps>> at [
+ remove-provider
+ thejit get mps>> delete-at
+ ] [ drop ] if* ;
+
+: add-module ( module name -- )
+ [ <provider> ] dip [ remove-module ] keep
+ thejit get ee>> value>> pick
+ [ [ value>> LLVMAddModuleProvider ] [ t >>disposed drop ] bi ] with-disposal
+ thejit get mps>> set-at ;
+
+: function-pointer ( name -- alien )
+ thejit get ee>> value>> dup
+ rot f <void*> [ LLVMFindFunction drop ] keep
+ *void* LLVMGetPointerToGlobal ;
+
+thejit [ <jit> ] initialize
\ No newline at end of file
--- /dev/null
+define i32 @add(i32 %x, i32 %y) {
+entry:
+ %sum = add i32 %x, %y
+ ret i32 %sum
+}
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax destructors kernel
+llvm.core llvm.engine llvm.jit llvm.wrappers ;
+
+IN: llvm.reader
+
+: buffer>module ( buffer -- module )
+ [
+ value>> f <void*> f <void*>
+ [ LLVMParseBitcode drop ] 2keep
+ *void* [ llvm-throw ] when* *void*
+ module new swap >>value
+ ] with-disposal ;
+
+: load-module ( path -- module )
+ <buffer> buffer>module ;
+
+: load-into-jit ( path name -- )
+ [ load-module ] dip add-module ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel llvm.types sequences tools.test ;
+
+[ T{ integer f 32 } ] [ " i32 " parse-type ] unit-test
+[ float ] [ " float " parse-type ] unit-test
+[ T{ pointer f f x86_fp80 } ] [ " x86_fp80 * " parse-type ] unit-test
+[ T{ vector f f 4 T{ integer f 32 } } ] [ " < 4 x i32 > " parse-type ] unit-test
+[ T{ struct f f { float double } f } ] [ TYPE: { float , double } ; ] unit-test
+[ T{ array f f 0 float } ] [ TYPE: [ 0 x float ] ; ] unit-test
+
+[ label void metadata ]
+[ [ " label " " void " " metadata " ] [ parse-type ] each ] unit-test
+
+[ T{ function f f float { float float } t } ]
+[ TYPE: float ( float , float , ... ) ; ] unit-test
+
+[ T{ struct f f { float TYPE: i32 (i32)* ; } t } ]
+[ TYPE: < { float, i32 (i32)* } > ; ] unit-test
+
+[ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] bi@ = ] unit-test
+[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test
+
+[ TYPE: i32 ; ] [ TYPE: i32 ; >tref tref> ] unit-test
+[ TYPE: float ; ] [ TYPE: float ; >tref tref> ] unit-test
+[ TYPE: double ; ] [ TYPE: double ; >tref tref> ] unit-test
+[ TYPE: x86_fp80 ; ] [ TYPE: x86_fp80 ; >tref tref> ] unit-test
+[ TYPE: fp128 ; ] [ TYPE: fp128 ; >tref tref> ] unit-test
+[ TYPE: ppc_fp128 ; ] [ TYPE: ppc_fp128 ; >tref tref> ] unit-test
+[ TYPE: opaque ; ] [ TYPE: opaque ; >tref tref> ] unit-test
+[ TYPE: label ; ] [ TYPE: label ; >tref tref> ] unit-test
+[ TYPE: void ; ] [ TYPE: void ; >tref tref> ] unit-test
+[ TYPE: i32* ; ] [ TYPE: i32* ; >tref tref> ] unit-test
+[ TYPE: < 2 x i32 > ; ] [ TYPE: < 2 x i32 > ; >tref tref> ] unit-test
+[ TYPE: [ 0 x i32 ] ; ] [ TYPE: [ 0 x i32 ] ; >tref tref> ] unit-test
+[ TYPE: { i32, i32 } ; ] [ TYPE: { i32, i32 } ; >tref tref> ] unit-test
+[ TYPE: < { i32, i32 } > ; ] [ TYPE: < { i32, i32 } > ; >tref tref> ] unit-test
+[ TYPE: i32 ( i32 ) ; ] [ TYPE: i32 ( i32 ) ; >tref tref> ] unit-test
+[ TYPE: \1* ; ] [ TYPE: \1* ; >tref tref> ] unit-test
+[ TYPE: { i32, \2* } ; ] [ TYPE: { i32, \2* } ; >tref tref> ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators kernel llvm.core
+locals math.parser math multiline
+namespaces parser peg.ebnf sequences
+sequences.deep specialized-arrays.alien strings vocabs words ;
+
+IN: llvm.types
+
+! Type resolution strategy:
+! pass 1:
+! create the type with uprefs mapped to opaque types
+! cache typerefs in enclosing types for pass 2
+! if our type is concrete, then we are done
+!
+! pass 2:
+! wrap our abstract type in a type handle
+! create a second type, using the cached enclosing type info
+! resolve the first type to the second
+!
+GENERIC: (>tref) ( type -- LLVMTypeRef )
+GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
+GENERIC: c-type ( type -- str )
+
+! default implementation for simple types
+M: object ((tref>)) nip ;
+: unsupported-type ( -- )
+ "cannot generate c-type: unsupported llvm type" throw ;
+M: object c-type unsupported-type ;
+
+TUPLE: integer size ;
+C: <integer> integer
+
+M: integer (>tref) size>> LLVMIntType ;
+M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
+M: integer c-type size>> {
+ { 64 [ "longlong" ] }
+ { 32 [ "int" ] }
+ { 16 [ "short" ] }
+ { 8 [ "char" ] }
+ [ unsupported-type ]
+} case ;
+
+SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
+
+M: float (>tref) drop LLVMFloatType ;
+M: double (>tref) drop LLVMDoubleType ;
+M: double c-type drop "double" ;
+M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
+M: fp128 (>tref) drop LLVMFP128Type ;
+M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
+
+SINGLETONS: opaque label void metadata ;
+
+M: opaque (>tref) drop LLVMOpaqueType ;
+M: label (>tref) drop LLVMLabelType ;
+M: void (>tref) drop LLVMVoidType ;
+M: void c-type drop "void" ;
+M: metadata (>tref) drop
+ "metadata types unsupported by llvm c bindings" throw ;
+
+! enclosing types cache their llvm refs during
+! the first pass, used in the second pass to
+! resolve uprefs
+TUPLE: enclosing cached ;
+
+GENERIC: clean ( type -- )
+GENERIC: clean* ( type -- )
+M: object clean drop ;
+M: enclosing clean f >>cached clean* ;
+
+! builds the stack of types that uprefs need to refer to
+SYMBOL: types
+:: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
+ type types get push
+ type quot call( type -- LLVMTypeRef )
+ types get pop over >>cached drop ;
+
+DEFER: <up-ref>
+:: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
+ ref types get index
+ [ types get length swap - <up-ref> ] [
+ ref types get push
+ ref quot call( LLVMTypeRef -- type )
+ types get pop drop
+ ] if* ;
+
+GENERIC: (>tref)* ( type -- LLVMTypeRef )
+M: enclosing (>tref) [ (>tref)* ] push-type ;
+
+DEFER: type-kind
+GENERIC: (tref>)* ( LLVMTypeRef type -- type )
+M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ;
+
+: (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ;
+
+TUPLE: pointer < enclosing type ;
+: <pointer> ( t -- o ) pointer new swap >>type ;
+
+M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
+M: pointer clean* type>> clean ;
+M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ;
+M: pointer c-type type>> 8 <integer> = "char*" "void*" ? ;
+
+TUPLE: vector < enclosing size type ;
+: <vector> ( s t -- o )
+ vector new
+ swap >>type swap >>size ;
+
+M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
+M: vector clean* type>> clean ;
+M: vector (tref>)*
+ over LLVMGetElementType (tref>) >>type
+ swap LLVMGetVectorSize >>size ;
+
+TUPLE: struct < enclosing types packed? ;
+: <struct> ( ts p? -- o )
+ struct new
+ swap >>packed? swap >>types ;
+
+M: struct (>tref)*
+ [ types>> [ (>tref) ] map >void*-array ]
+ [ types>> length ]
+ [ packed?>> 1 0 ? ] tri LLVMStructType ;
+M: struct clean* types>> [ clean ] each ;
+M: struct (tref>)*
+ over LLVMIsPackedStruct 0 = not >>packed?
+ swap dup LLVMCountStructElementTypes <void*-array>
+ [ LLVMGetStructElementTypes ] keep >array
+ [ (tref>) ] map >>types ;
+
+TUPLE: array < enclosing size type ;
+: <array> ( s t -- o )
+ array new
+ swap >>type swap >>size ;
+
+M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
+M: array clean* type>> clean ;
+M: array (tref>)*
+ over LLVMGetElementType (tref>) >>type
+ swap LLVMGetArrayLength >>size ;
+
+SYMBOL: ...
+TUPLE: function < enclosing return params vararg? ;
+: <function> ( ret params var? -- o )
+ function new
+ swap >>vararg? swap >>params swap >>return ;
+
+M: function (>tref)* {
+ [ return>> (>tref) ]
+ [ params>> [ (>tref) ] map >void*-array ]
+ [ params>> length ]
+ [ vararg?>> 1 0 ? ]
+} cleave LLVMFunctionType ;
+M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
+M: function (tref>)*
+ over LLVMIsFunctionVarArg 0 = not >>vararg?
+ over LLVMGetReturnType (tref>) >>return
+ swap dup LLVMCountParamTypes <void*-array>
+ [ LLVMGetParamTypes ] keep >array
+ [ (tref>) ] map >>params ;
+
+: type-kind ( LLVMTypeRef -- class )
+ LLVMGetTypeKind {
+ { LLVMVoidTypeKind [ void ] }
+ { LLVMFloatTypeKind [ float ] }
+ { LLVMDoubleTypeKind [ double ] }
+ { LLVMX86_FP80TypeKind [ x86_fp80 ] }
+ { LLVMFP128TypeKind [ fp128 ] }
+ { LLVMPPC_FP128TypeKind [ ppc_fp128 ] }
+ { LLVMLabelTypeKind [ label ] }
+ { LLVMIntegerTypeKind [ integer new ] }
+ { LLVMFunctionTypeKind [ function new ] }
+ { LLVMStructTypeKind [ struct new ] }
+ { LLVMArrayTypeKind [ array new ] }
+ { LLVMPointerTypeKind [ pointer new ] }
+ { LLVMOpaqueTypeKind [ opaque ] }
+ { LLVMVectorTypeKind [ vector new ] }
+ } case ;
+
+TUPLE: up-ref height ;
+C: <up-ref> up-ref
+
+M: up-ref (>tref)
+ types get length swap height>> - types get nth
+ cached>> [ LLVMOpaqueType ] unless* ;
+
+: resolve-types ( typeref typeref -- typeref )
+ over LLVMCreateTypeHandle [ LLVMRefineType ] dip
+ [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
+
+: >tref-caching ( type -- LLVMTypeRef )
+ V{ } clone types [ (>tref) ] with-variable ;
+
+: >tref ( type -- LLVMTypeRef )
+ [ >tref-caching ] [ >tref-caching ] [ clean ] tri
+ 2dup = [ drop ] [ resolve-types ] if ;
+
+: tref> ( LLVMTypeRef -- type )
+ V{ } clone types [ (tref>) ] with-variable ;
+
+: t. ( type -- )
+ >tref
+ "type-info" LLVMModuleCreateWithName
+ [ "t" rot LLVMAddTypeName drop ]
+ [ LLVMDumpModule ]
+ [ LLVMDisposeModule ] tri ;
+
+EBNF: parse-type
+
+WhiteSpace = " "*
+
+Zero = "0" => [[ drop 0 ]]
+LeadingDigit = [1-9]
+DecimalDigit = [0-9]
+Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
+WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
+WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
+
+Integer = "i" Number:n => [[ n <integer> ]]
+FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]]
+LabelVoidMetadata = ( "label" | "void" | "metadata" | "opaque" ) => [[ "llvm.types" vocab lookup ]]
+Primitive = LabelVoidMetadata | FloatingPoint
+Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
+Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
+StructureTypesList = "," Type:t => [[ t ]]
+Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
+Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
+NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
+VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
+ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
+ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
+Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
+PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
+UpReference = "\\" Number:n => [[ n <up-ref> ]]
+Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
+
+T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
+
+Type = WhiteSpace T:t WhiteSpace => [[ t ]]
+
+Program = Type
+
+;EBNF
+
+SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: destructors kernel llvm.wrappers sequences tools.test vocabs ;
+
+[ ] [ "test" <module> dispose ] unit-test
+[ ] [ "test" <module> <provider> dispose ] unit-test
+[ ] [ "llvm.jit" vocabs member? [ "test" <module> <provider> <engine> dispose ] unless ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings
+io.encodings.utf8 destructors kernel
+llvm.core llvm.engine ;
+
+IN: llvm.wrappers
+
+: llvm-throw ( char* -- )
+ [ utf8 alien>string ] [ LLVMDisposeMessage ] bi throw ;
+
+: <dispose> ( alien class -- disposable ) new swap >>value ;
+
+TUPLE: module value disposed ;
+M: module dispose* value>> LLVMDisposeModule ;
+
+: <module> ( name -- module )
+ LLVMModuleCreateWithName module <dispose> ;
+
+TUPLE: provider value module disposed ;
+M: provider dispose* value>> LLVMDisposeModuleProvider ;
+
+: (provider) ( module -- provider )
+ [ value>> LLVMCreateModuleProviderForExistingModule provider <dispose> ]
+ [ t >>disposed value>> ] bi
+ >>module ;
+
+: <provider> ( module -- provider )
+ [ (provider) ] with-disposal ;
+
+TUPLE: engine value disposed ;
+M: engine dispose* value>> LLVMDisposeExecutionEngine ;
+
+: (engine) ( provider -- engine )
+ [
+ value>> f <void*> f <void*>
+ [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
+ *void* [ llvm-throw ] when* *void*
+ ]
+ [ t >>disposed drop ] bi
+ engine <dispose> ;
+
+: <engine> ( provider -- engine )
+ [ (engine) ] with-disposal ;
+
+: (add-block) ( name -- basic-block )
+ "function" swap LLVMAppendBasicBlock ;
+
+TUPLE: builder value disposed ;
+M: builder dispose* value>> LLVMDisposeBuilder ;
+
+: <builder> ( name -- builder )
+ (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
+ builder <dispose> ;
+
+TUPLE: buffer value disposed ;
+M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
+
+: <buffer> ( path -- module )
+ f <void*> f <void*>
+ [ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
+ *void* [ llvm-throw ] when* *void* buffer <dispose> ;
\ No newline at end of file
f swap open-window* ;
: into-window ( world quot -- world )
- [ dup handle>> ] dip with-gl-context ; inline
+ [ dup ] dip with-gl-context ; inline
.
.
; "> }
-{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code <"
USING: kernel variants ;
IN: scratchpad
HELP: match
{ $values { "branches" array } }
-{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
{ $examples { $example <"
USING: kernel math prettyprint variants ;
IN: scratchpad
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel furnace.actions html.forms
-http.server.dispatchers db db.tuples db.types urls
-furnace.redirection multiline http namespaces ;
+USING: accessors furnace.actions furnace.redirection
+html.forms http http.server http.server.dispatchers
+io.directories io.encodings.utf8 io.files io.pathnames
+kernel math.parser multiline namespaces sequences urls ;
IN: webapps.imagebin
-TUPLE: imagebin < dispatcher ;
-
-TUPLE: image id path ;
-
-image "IMAGE" {
- { "id" "ID" INTEGER +db-assigned-id+ }
- { "path" "PATH" { VARCHAR 256 } +not-null+ }
-} define-persistent
+TUPLE: imagebin < dispatcher path n ;
: <uploaded-image-action> ( -- action )
<page-action>
{ imagebin "uploaded-image" } >>template ;
-SYMBOL: my-post-data
+: next-image-path ( -- path )
+ imagebin get
+ [ path>> ] [ n>> number>string ] bi append-path ;
+
+M: imagebin call-responder*
+ [ imagebin set ] [ call-next-method ] bi ;
+
+: move-image ( mime-file -- )
+ next-image-path
+ [ [ temporary-path>> ] dip move-file ]
+ [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
+
: <upload-image-action> ( -- action )
<page-action>
{ imagebin "upload-image" } >>template
[
-
- ! request get post-data>> my-post-data set-global
- ! image new
- ! "file" value
- ! insert-tuple
+ "file1" param [ move-image ] when*
+ "file2" param [ move-image ] when*
+ "file3" param [ move-image ] when*
"uploaded-image" <redirect>
] >>submit ;
-: <imagebin> ( -- responder )
+: <imagebin> ( image-directory -- responder )
imagebin new-dispatcher
+ swap [ make-directories ] [ >>path ] bi
+ 0 >>n
<upload-image-action> "" add-responder
<upload-image-action> "upload-image" add-responder
<uploaded-image-action> "uploaded-image" add-responder ;
+"resource:images" <imagebin> main-responder set-global
<html>
<head><title>Uploaded</title></head>
<body>
-hi from uploaded-image
+You uploaded something!
</body>
</html>
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel
-cocoa
-cocoa.application
-cocoa.types
-cocoa.classes
-cocoa.windows
-core-graphics.types ;
+USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
+core-graphics.types kernel math.bitwise ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
+: window-style ( -- n )
+ {
+ NSClosableWindowMask
+ NSMiniaturizableWindowMask
+ NSResizableWindowMask
+ NSTitledWindowMask
+ } flags ;
+
: <WebWindow> ( -- id )
- <WebView> rect <ViewWindow> ;
+ <WebView> rect window-style <ViewWindow> ;
: load-url ( window url -- )
[ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect