Merge branch 'master' of git://factorcode.org/git/factor
commit
79afab82d8
|
@ -2,12 +2,19 @@
|
|||
! 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 make sequences system vocabs.parser words ;
|
||||
locals make sequences system vocabs.parser words io.directories
|
||||
io.pathnames ;
|
||||
IN: alien.inline.compiler
|
||||
|
||||
SYMBOL: C
|
||||
SYMBOL: C++
|
||||
|
||||
: inline-libs-directory ( -- path )
|
||||
"alien-inline-libs" resource-path dup make-directories ;
|
||||
|
||||
: inline-library-file ( name -- path )
|
||||
inline-libs-directory prepend-path ;
|
||||
|
||||
: library-suffix ( -- str )
|
||||
os {
|
||||
{ [ dup macosx? ] [ drop ".dylib" ] }
|
||||
|
@ -16,10 +23,7 @@ SYMBOL: C++
|
|||
} cond ;
|
||||
|
||||
: library-path ( str -- str' )
|
||||
'[
|
||||
"lib-" % current-vocab name>> %
|
||||
"-" % _ % library-suffix %
|
||||
] "" make temp-file ;
|
||||
'[ "lib" % _ % library-suffix % ] "" make temp-file ;
|
||||
|
||||
: src-suffix ( lang -- str )
|
||||
{
|
||||
|
|
|
@ -0,0 +1,211 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel strings effects quotations ;
|
||||
IN: alien.inline
|
||||
|
||||
: $binding-note ( x -- )
|
||||
drop
|
||||
{ "This word requires that certain variables are correctly bound. "
|
||||
"Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
|
||||
|
||||
HELP: ;C-LIBRARY
|
||||
{ $syntax ";C-LIBRARY" }
|
||||
{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
|
||||
{ $see-also POSTPONE: compile-c-library } ;
|
||||
|
||||
HELP: C-FRAMEWORK:
|
||||
{ $syntax "C-FRAMEWORK: name" }
|
||||
{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
|
||||
{ $see-also POSTPONE: c-use-framework } ;
|
||||
|
||||
HELP: C-FUNCTION:
|
||||
{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
|
||||
{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline prettyprint ;"
|
||||
"IN: cmath.ffi"
|
||||
""
|
||||
"C-LIBRARY: cmathlib"
|
||||
""
|
||||
"C-FUNCTION: int add ( int a, int b )"
|
||||
" return a + b;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
""
|
||||
"1 2 add ."
|
||||
"3" }
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-function } ;
|
||||
|
||||
HELP: C-INCLUDE:
|
||||
{ $syntax "C-INCLUDE: name" }
|
||||
{ $description "Appends an include line to the C library in scope." }
|
||||
{ $see-also POSTPONE: c-include } ;
|
||||
|
||||
HELP: C-LIBRARY:
|
||||
{ $syntax "C-LIBRARY: name" }
|
||||
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline ;"
|
||||
"IN: rectangle.ffi"
|
||||
""
|
||||
"C-LIBRARY: rectlib"
|
||||
""
|
||||
"C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
|
||||
""
|
||||
"C-FUNCTION: int area ( rectangle c )"
|
||||
" return c.width * c.height;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
"" }
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-library } ;
|
||||
|
||||
HELP: C-LINK/FRAMEWORK:
|
||||
{ $syntax "C-LINK/FRAMEWORK: name" }
|
||||
{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
|
||||
{ $see-also POSTPONE: c-link-to/use-framework } ;
|
||||
|
||||
HELP: C-LINK:
|
||||
{ $syntax "C-LINK: name" }
|
||||
{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
|
||||
{ $see-also POSTPONE: c-link-to } ;
|
||||
|
||||
HELP: C-STRUCTURE:
|
||||
{ $syntax "C-STRUCTURE: name pairs ... ;" }
|
||||
{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
|
||||
{ $see-also POSTPONE: define-c-struct } ;
|
||||
|
||||
HELP: C-TYPEDEF:
|
||||
{ $syntax "C-TYPEDEF: old new" }
|
||||
{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
|
||||
{ $see-also POSTPONE: define-c-typedef } ;
|
||||
|
||||
HELP: COMPILE-AS-C++
|
||||
{ $syntax "COMPILE-AS-C++" }
|
||||
{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
|
||||
|
||||
HELP: DELETE-C-LIBRARY:
|
||||
{ $syntax "DELETE-C-LIBRARY: name" }
|
||||
{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
|
||||
{ $notes
|
||||
{ $list
|
||||
{ "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
|
||||
"This word is mainly useful for unit tests."
|
||||
}
|
||||
}
|
||||
{ $see-also POSTPONE: delete-inline-library } ;
|
||||
|
||||
HELP: RAW-C:
|
||||
{ $syntax "RAW-C:" "body" ";" }
|
||||
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
|
||||
|
||||
CONSTANT: foo "abc"
|
||||
|
||||
HELP: compile-c-library
|
||||
{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
|
||||
"Also calls " { $snippet "add-library" } ". "
|
||||
"This word does nothing if the shared library is younger than the factor source file." }
|
||||
{ $notes $binding-note } ;
|
||||
|
||||
HELP: c-use-framework
|
||||
{ $values
|
||||
{ "str" string }
|
||||
}
|
||||
{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
|
||||
{ $notes $binding-note }
|
||||
{ $see-also c-link-to c-link-to/use-framework } ;
|
||||
|
||||
HELP: define-c-function
|
||||
{ $values
|
||||
{ "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
|
||||
}
|
||||
{ $description "Defines a C function and a factor word which calls it." }
|
||||
{ $notes
|
||||
{ $list
|
||||
{ "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
|
||||
{ "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
|
||||
$binding-note
|
||||
}
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-function' } ;
|
||||
|
||||
HELP: define-c-function'
|
||||
{ $values
|
||||
{ "function" "function name" } { "effect" effect } { "body" string }
|
||||
}
|
||||
{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
|
||||
{ $notes
|
||||
{ $list
|
||||
{ "Each effect element must be a legal C type with dashes (-) instead of spaces. "
|
||||
"C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
|
||||
$binding-note
|
||||
}
|
||||
}
|
||||
{ $see-also define-c-function } ;
|
||||
|
||||
HELP: c-include
|
||||
{ $values
|
||||
{ "str" string }
|
||||
}
|
||||
{ $description "Appends an include line to the C library in scope." }
|
||||
{ $notes $binding-note } ;
|
||||
|
||||
HELP: define-c-library
|
||||
{ $values
|
||||
{ "name" string }
|
||||
}
|
||||
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
|
||||
|
||||
HELP: c-link-to
|
||||
{ $values
|
||||
{ "str" string }
|
||||
}
|
||||
{ $description "Adds " { $snippet "-lname" } " to linker command." }
|
||||
{ $notes $binding-note }
|
||||
{ $see-also c-use-framework c-link-to/use-framework } ;
|
||||
|
||||
HELP: c-link-to/use-framework
|
||||
{ $values
|
||||
{ "str" string }
|
||||
}
|
||||
{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
|
||||
{ $notes $binding-note }
|
||||
{ $see-also c-link-to c-use-framework } ;
|
||||
|
||||
HELP: define-c-struct
|
||||
{ $values
|
||||
{ "name" string } { "fields" "type/name pairs" }
|
||||
}
|
||||
{ $description "Defines a C struct and factor words which operate on it." }
|
||||
{ $notes $binding-note } ;
|
||||
|
||||
HELP: define-c-typedef
|
||||
{ $values
|
||||
{ "old" "C type" } { "new" "C type" }
|
||||
}
|
||||
{ $description "Define C and factor typedefs." }
|
||||
{ $notes $binding-note } ;
|
||||
|
||||
HELP: delete-inline-library
|
||||
{ $values
|
||||
{ "name" string }
|
||||
}
|
||||
{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
|
||||
{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
|
||||
|
||||
HELP: with-c-library
|
||||
{ $values
|
||||
{ "name" string } { "quot" quotation }
|
||||
}
|
||||
{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
|
||||
|
||||
ARTICLE: "alien.inline" "Inline C"
|
||||
{ $vocab-link "alien.inline" }
|
||||
;
|
||||
|
||||
ABOUT: "alien.inline"
|
|
@ -6,7 +6,7 @@ generalizations grouping io.directories io.files
|
|||
io.files.info io.files.temp kernel lexer math math.order
|
||||
math.ranges multiline namespaces sequences source-files
|
||||
splitting strings system vocabs.loader vocabs.parser words
|
||||
alien.c-types alien.structs make parser ;
|
||||
alien.c-types alien.structs make parser continuations ;
|
||||
IN: alien.inline
|
||||
|
||||
<PRIVATE
|
||||
|
@ -15,6 +15,10 @@ SYMBOL: library-is-c++
|
|||
SYMBOL: compiler-args
|
||||
SYMBOL: c-strings
|
||||
|
||||
: cleanup-variables ( -- )
|
||||
{ c-library library-is-c++ compiler-args c-strings }
|
||||
[ off ] each ;
|
||||
|
||||
: function-types-effect ( -- function types effect )
|
||||
scan scan swap ")" parse-tokens
|
||||
[ "(" subseq? not ] filter swap parse-arglist ;
|
||||
|
@ -39,8 +43,8 @@ SYMBOL: c-strings
|
|||
: 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 ;
|
||||
: append-function-body ( prototype-str body -- str )
|
||||
[ swap % " {\n" % % "\n}\n" % ] "" make ;
|
||||
|
||||
: compile-library? ( -- ? )
|
||||
c-library get library-path dup exists? [
|
||||
|
@ -55,10 +59,13 @@ SYMBOL: c-strings
|
|||
compiler-args get
|
||||
c-strings get "\n" join
|
||||
c-library get compile-to-library ;
|
||||
|
||||
: c-library-name ( name -- name' )
|
||||
[ current-vocab name>> % "_" % % ] "" make ;
|
||||
PRIVATE>
|
||||
|
||||
: define-c-library ( name -- )
|
||||
c-library set
|
||||
c-library-name c-library set
|
||||
V{ } clone c-strings set
|
||||
V{ } clone compiler-args set ;
|
||||
|
||||
|
@ -66,25 +73,29 @@ PRIVATE>
|
|||
compile-library? [ compile-library ] when
|
||||
c-library get dup 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 types effect body -- )
|
||||
[
|
||||
[ factor-function define-declared ]
|
||||
[ prototype-string ] 3bi
|
||||
] dip 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-function' ( function effect body -- )
|
||||
[
|
||||
[ in>> ] keep
|
||||
[ factor-function define-declared ]
|
||||
[ out>> prototype-string' ] 3bi
|
||||
] dip append-function-body c-strings get push ;
|
||||
|
||||
: define-c-link ( str -- )
|
||||
: c-link-to ( str -- )
|
||||
"-l" prepend compiler-args get push ;
|
||||
|
||||
: define-c-framework ( str -- )
|
||||
: c-use-framework ( str -- )
|
||||
"-framework" swap compiler-args get '[ _ push ] bi@ ;
|
||||
|
||||
: define-c-link/framework ( str -- )
|
||||
os macosx? [ define-c-framework ] [ define-c-link ] if ;
|
||||
: c-link-to/use-framework ( str -- )
|
||||
os macosx? [ c-use-framework ] [ c-link-to ] if ;
|
||||
|
||||
: define-c-include ( str -- )
|
||||
: c-include ( str -- )
|
||||
"#include " prepend c-strings get push ;
|
||||
|
||||
: define-c-typedef ( old new -- )
|
||||
|
@ -93,38 +104,43 @@ PRIVATE>
|
|||
"" make c-strings get push
|
||||
] 2bi ;
|
||||
|
||||
: define-c-struct ( name vocab fields -- )
|
||||
[ define-struct ] [
|
||||
nip over
|
||||
: define-c-struct ( name fields -- )
|
||||
[ current-vocab swap define-struct ] [
|
||||
over
|
||||
[
|
||||
"typedef struct " % "_" % % " {\n" %
|
||||
[ first2 swap % " " % % ";\n" % ] each
|
||||
"} " % % ";\n" %
|
||||
] "" make c-strings get push
|
||||
] 3bi ;
|
||||
] 2bi ;
|
||||
|
||||
: delete-inline-library ( str -- )
|
||||
library-path dup exists? [ delete-file ] [ drop ] if ;
|
||||
: delete-inline-library ( name -- )
|
||||
c-library-name [ remove-library ]
|
||||
[ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
|
||||
|
||||
: with-c-library ( name quot -- )
|
||||
[ [ define-c-library ] dip call compile-c-library ]
|
||||
[ cleanup-variables ] [ ] cleanup ; inline
|
||||
|
||||
SYNTAX: C-LIBRARY: scan define-c-library ;
|
||||
|
||||
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
|
||||
|
||||
SYNTAX: C-LINK: scan define-c-link ;
|
||||
SYNTAX: C-LINK: scan c-link-to ;
|
||||
|
||||
SYNTAX: C-FRAMEWORK: scan define-c-framework ;
|
||||
SYNTAX: C-FRAMEWORK: scan c-use-framework ;
|
||||
|
||||
SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
|
||||
SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
|
||||
|
||||
SYNTAX: C-INCLUDE: scan define-c-include ;
|
||||
SYNTAX: C-INCLUDE: scan c-include ;
|
||||
|
||||
SYNTAX: C-FUNCTION:
|
||||
function-types-effect define-c-function ;
|
||||
function-types-effect parse-here define-c-function ;
|
||||
|
||||
SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
|
||||
|
||||
SYNTAX: C-STRUCTURE:
|
||||
scan current-vocab parse-definition define-c-struct ;
|
||||
scan parse-definition define-c-struct ;
|
||||
|
||||
SYNTAX: ;C-LIBRARY compile-c-library ;
|
||||
|
||||
|
|
|
@ -40,7 +40,10 @@ test-diamond
|
|||
[ 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
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
|
||||
[ 3 get successors>> first instructions>> first ]
|
||||
unit-test
|
||||
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
||||
|
||||
V{
|
||||
|
|
|
@ -1,7 +1,10 @@
|
|||
! 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 ;
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg ;
|
||||
IN: compiler.cfg.branch-folding
|
||||
|
||||
! Fold comparisons where both inputs are the same. Predecessors must be
|
||||
|
@ -27,4 +30,4 @@ IN: compiler.cfg.branch-folding
|
|||
dup fold-branch?
|
||||
[ fold-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
|
@ -0,0 +1,85 @@
|
|||
USING: accessors assocs compiler.cfg
|
||||
compiler.cfg.branch-splitting compiler.cfg.debugger
|
||||
compiler.cfg.predecessors compiler.cfg.rpo fry kernel
|
||||
tools.test namespaces sequences vectors ;
|
||||
IN: compiler.cfg.branch-splitting.tests
|
||||
|
||||
: get-predecessors ( cfg -- assoc )
|
||||
H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ;
|
||||
|
||||
: check-predecessors ( cfg -- )
|
||||
[ get-predecessors ]
|
||||
[ compute-predecessors drop ]
|
||||
[ get-predecessors ] tri assert= ;
|
||||
|
||||
: check-branch-splitting ( cfg -- )
|
||||
compute-predecessors
|
||||
split-branches
|
||||
check-predecessors ;
|
||||
|
||||
: test-branch-splitting ( -- )
|
||||
cfg new 0 get >>entry check-branch-splitting ;
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
||||
V{ } 1 test-bb
|
||||
|
||||
V{ } 2 test-bb
|
||||
|
||||
V{ } 3 test-bb
|
||||
|
||||
V{ } 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
||||
V{ } 1 test-bb
|
||||
|
||||
V{ } 2 test-bb
|
||||
|
||||
V{ } 3 test-bb
|
||||
|
||||
V{ } 4 test-bb
|
||||
|
||||
V{ } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
|
||||
2 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
||||
V{ } 1 test-bb
|
||||
|
||||
V{ } 2 test-bb
|
||||
|
||||
V{ } 3 test-bb
|
||||
|
||||
V{ } 4 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
|
||||
2 get 4 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
||||
V{ } 1 test-bb
|
||||
|
||||
V{ } 2 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
|
@ -1,37 +1,79 @@
|
|||
! 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 ;
|
||||
USING: accessors combinators.short-circuit kernel math math.order
|
||||
sequences assocs namespaces vectors fry arrays splitting
|
||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
|
||||
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.branch-splitting
|
||||
|
||||
! Predecessors must be recomputed after this
|
||||
: clone-renamings ( insns -- assoc )
|
||||
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
|
||||
|
||||
: split-branch-for ( bb predecessor -- )
|
||||
[
|
||||
: clone-instructions ( insns -- insns' )
|
||||
dup clone-renamings renamings [
|
||||
[
|
||||
<basic-block>
|
||||
swap
|
||||
[ instructions>> [ clone ] map >>instructions ]
|
||||
[ successors>> clone >>successors ]
|
||||
bi
|
||||
] keep
|
||||
] dip
|
||||
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
|
||||
drop ;
|
||||
clone
|
||||
dup rename-insn-defs
|
||||
dup rename-insn-uses
|
||||
dup fresh-insn-temps
|
||||
] map
|
||||
] with-variable ;
|
||||
|
||||
: clone-basic-block ( bb -- bb' )
|
||||
! The new block gets the same RPO number as the old one.
|
||||
! This is just to make 'back-edge?' work.
|
||||
<basic-block>
|
||||
swap
|
||||
[ instructions>> clone-instructions >>instructions ]
|
||||
[ successors>> clone >>successors ]
|
||||
[ number>> >>number ]
|
||||
tri ;
|
||||
|
||||
: new-blocks ( bb -- copies )
|
||||
dup predecessors>> [
|
||||
[ clone-basic-block ] dip
|
||||
1vector >>predecessors
|
||||
] with map ;
|
||||
|
||||
: update-predecessor-successor ( pred copy old-bb -- )
|
||||
'[
|
||||
[ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
|
||||
] change-successors drop ;
|
||||
|
||||
: update-predecessor-successors ( copies old-bb -- )
|
||||
[ predecessors>> swap ] keep
|
||||
'[ _ update-predecessor-successor ] 2each ;
|
||||
|
||||
: update-successor-predecessor ( copies old-bb succ -- )
|
||||
[
|
||||
swap 1array split swap join V{ } like
|
||||
] change-predecessors drop ;
|
||||
|
||||
: update-successor-predecessors ( copies old-bb -- )
|
||||
dup successors>> [
|
||||
update-successor-predecessor
|
||||
] with with each ;
|
||||
|
||||
: split-branch ( bb -- )
|
||||
dup predecessors>> [ split-branch-for ] with each ;
|
||||
[ new-blocks ] keep
|
||||
[ update-predecessor-successors ]
|
||||
[ update-successor-predecessors ]
|
||||
2bi ;
|
||||
|
||||
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
|
||||
|
||||
: split-instructions? ( insns -- ? )
|
||||
[ irrelevant? not ] count 5 <= ;
|
||||
|
||||
: split-branches? ( bb -- ? )
|
||||
{
|
||||
[ successors>> empty? ]
|
||||
[ predecessors>> length 1 > ]
|
||||
[ instructions>> [ defs-vregs ] any? not ]
|
||||
[ instructions>> [ temp-vregs ] any? not ]
|
||||
[ dup successors>> [ back-edge? ] with any? not ]
|
||||
[ predecessors>> length 1 4 between? ]
|
||||
[ instructions>> split-instructions? ]
|
||||
} 1&& ;
|
||||
|
||||
: split-branches ( cfg -- cfg' )
|
||||
dup [
|
||||
dup split-branches? [ split-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
||||
|
|
|
@ -14,6 +14,7 @@ compiler.cfg.stacks
|
|||
compiler.cfg.utilities
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.intrinsics
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.instructions
|
||||
compiler.alien ;
|
||||
|
|
|
@ -1,9 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays vectors accessors assocs sets
|
||||
namespaces math make fry sequences
|
||||
combinators.short-circuit
|
||||
compiler.cfg.instructions ;
|
||||
USING: kernel math vectors arrays accessors namespaces ;
|
||||
IN: compiler.cfg
|
||||
|
||||
TUPLE: basic-block < identity-tuple
|
||||
|
@ -22,36 +19,12 @@ M: basic-block hashcode* nip id>> ;
|
|||
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
|
||||
_ dip
|
||||
building get push
|
||||
] with-variable ; inline
|
||||
|
||||
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
|
||||
|
||||
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
||||
|
||||
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
: <mr> ( instructions word label -- mr )
|
||||
|
|
|
@ -0,0 +1,36 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs math.order sequences ;
|
||||
IN: compiler.cfg.comparisons
|
||||
|
||||
SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
|
||||
|
||||
: negate-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc>= }
|
||||
{ cc<= cc> }
|
||||
{ cc> cc<= }
|
||||
{ cc>= cc< }
|
||||
{ cc= cc/= }
|
||||
{ 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+ } }
|
||||
{ cc<= { +lt+ +eq+ } }
|
||||
{ cc= { +eq+ } }
|
||||
{ cc>= { +eq+ +gt+ } }
|
||||
{ cc> { +gt+ } }
|
||||
{ cc/= { +lt+ +gt+ } }
|
||||
} at memq? ;
|
|
@ -26,7 +26,7 @@ M: word test-cfg
|
|||
] map ;
|
||||
|
||||
: insn. ( insn -- )
|
||||
tuple>array [ pprint bl ] each nl ;
|
||||
tuple>array but-last [ pprint bl ] each nl ;
|
||||
|
||||
: mr. ( mrs -- )
|
||||
[
|
||||
|
|
|
@ -181,44 +181,6 @@ INSN: ##loop-entry ;
|
|||
|
||||
INSN: ##phi < ##pure inputs ;
|
||||
|
||||
! Condition codes
|
||||
SYMBOL: cc<
|
||||
SYMBOL: cc<=
|
||||
SYMBOL: cc=
|
||||
SYMBOL: cc>
|
||||
SYMBOL: cc>=
|
||||
SYMBOL: cc/=
|
||||
|
||||
: negate-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc>= }
|
||||
{ cc<= cc> }
|
||||
{ cc> cc<= }
|
||||
{ cc>= cc< }
|
||||
{ cc= cc/= }
|
||||
{ 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+ } }
|
||||
{ cc<= { +lt+ +eq+ } }
|
||||
{ cc= { +eq+ } }
|
||||
{ cc>= { +eq+ +gt+ } }
|
||||
{ cc> { +gt+ } }
|
||||
{ cc/= { +lt+ +gt+ } }
|
||||
} at memq? ;
|
||||
|
||||
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
|
||||
|
||||
INSN: ##compare-branch < ##conditional-branch ;
|
||||
|
|
|
@ -7,7 +7,8 @@ compiler.cfg.hats
|
|||
compiler.cfg.stacks
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers ;
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.comparisons ;
|
||||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: emit-both-fixnums? ( -- )
|
||||
|
|
|
@ -8,7 +8,8 @@ compiler.cfg.intrinsics.allot
|
|||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc ;
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.comparisons ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
QUALIFIED: byte-arrays
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences
|
||||
USING: accessors kernel sequences namespaces assocs fry
|
||||
combinators.short-circuit
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.allocation.state ;
|
||||
|
@ -20,9 +20,16 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
|
|||
[ avoids-inactive-intervals? ]
|
||||
} 1&& ;
|
||||
|
||||
: reuse-spill-slot ( old new -- )
|
||||
[ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
|
||||
|
||||
: reuse-register ( old new -- )
|
||||
reg>> >>reg drop ;
|
||||
|
||||
: (coalesce) ( old new -- )
|
||||
[ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
|
||||
|
||||
: coalesce ( live-interval -- )
|
||||
dup copy-from>> active-interval
|
||||
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
|
||||
[ reg>> >>reg drop ]
|
||||
2bi ;
|
||||
[ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
|
||||
|
|
@ -17,7 +17,7 @@ ERROR: bad-live-ranges interval ;
|
|||
] [ drop ] if ;
|
||||
|
||||
: trim-before-ranges ( live-interval -- )
|
||||
[ ranges>> ] [ uses>> last ] bi
|
||||
[ ranges>> ] [ uses>> last 1 + ] bi
|
||||
[ '[ from>> _ <= ] filter-here ]
|
||||
[ swap last (>>to) ]
|
||||
2bi ;
|
||||
|
|
|
@ -150,7 +150,7 @@ ERROR: bad-live-values live-values ;
|
|||
|
||||
: begin-block ( bb -- )
|
||||
dup basic-block set
|
||||
dup block-from prepare-insn
|
||||
dup block-from activate-new-intervals
|
||||
[ [ live-in ] [ block-from ] bi compute-live-values ] keep
|
||||
register-live-ins get set-at ;
|
||||
|
||||
|
|
|
@ -82,9 +82,9 @@ check-numbering? on
|
|||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ end 2 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ ranges V{ T{ live-range f 0 2 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
@ -107,9 +107,9 @@ check-numbering? on
|
|||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 0 } } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
@ -132,9 +132,9 @@ check-numbering? on
|
|||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 0 } } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
@ -1317,38 +1317,6 @@ USING: math.private ;
|
|||
allocate-registers drop
|
||||
] unit-test
|
||||
|
||||
! Spill slot liveness was computed incorrectly, leading to a FEP
|
||||
! early in bootstrap on x86-32
|
||||
[ t ] [
|
||||
[
|
||||
H{ } clone live-ins set
|
||||
H{ } clone live-outs set
|
||||
H{ } clone phi-live-ins set
|
||||
T{ basic-block
|
||||
{ id 12345 }
|
||||
{ instructions
|
||||
V{
|
||||
T{ ##gc f V int-regs 6 V int-regs 7 }
|
||||
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 4 }
|
||||
T{ ##peek f V int-regs 5 D 5 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 2 }
|
||||
T{ ##replace f V int-regs 2 D 3 }
|
||||
T{ ##replace f V int-regs 3 D 4 }
|
||||
T{ ##replace f V int-regs 4 D 5 }
|
||||
T{ ##replace f V int-regs 5 D 0 }
|
||||
}
|
||||
}
|
||||
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
|
||||
instructions>> first
|
||||
live-values>> assoc-empty?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ live-range f 0 10 }
|
||||
T{ live-range f 20 30 }
|
||||
|
@ -1541,6 +1509,7 @@ SYMBOL: linear-scan-result
|
|||
compute-liveness
|
||||
dup reverse-post-order
|
||||
{ { int-regs regs } } (linear-scan)
|
||||
cfg-changed
|
||||
flatten-cfg 1array mr.
|
||||
] with-scope ;
|
||||
|
||||
|
@ -1802,7 +1771,8 @@ test-diamond
|
|||
2 get instructions>> first regs>> V int-regs 1 swap at assert=
|
||||
] unit-test
|
||||
|
||||
[ _copy ] [ 3 get instructions>> second class ] unit-test
|
||||
! Not until splitting is finished
|
||||
! [ _copy ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
! Resolve pass; make sure the spilling is done correctly
|
||||
V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
|
||||
|
@ -1834,7 +1804,7 @@ test-diamond
|
|||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ _spill ] [ 2 get instructions>> first class ] unit-test
|
||||
[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
|
||||
|
||||
[ _spill ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
|
@ -1890,7 +1860,7 @@ V{
|
|||
|
||||
[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
|
||||
|
||||
[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
|
||||
[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
|
||||
|
||||
[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
|
||||
|
||||
|
@ -1957,7 +1927,7 @@ V{
|
|||
[ 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
|
||||
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
|
||||
|
||||
! Some random bug
|
||||
V{
|
||||
|
@ -2482,4 +2452,161 @@ V{
|
|||
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
|
||||
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
! Fencepost error in assignment 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{ ##branch } } 2 test-bb
|
||||
|
||||
V{
|
||||
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 }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
|
||||
|
||||
! Another test case for fencepost error in assignment 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{ ##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{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
|
||||
|
||||
[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
|
||||
|
||||
! GC check tests
|
||||
|
||||
! Spill slot liveness was computed incorrectly, leading to a FEP
|
||||
! early in bootstrap on x86-32
|
||||
[ t ] [
|
||||
[
|
||||
H{ } clone live-ins set
|
||||
H{ } clone live-outs set
|
||||
H{ } clone phi-live-ins set
|
||||
T{ basic-block
|
||||
{ id 12345 }
|
||||
{ instructions
|
||||
V{
|
||||
T{ ##gc f V int-regs 6 V int-regs 7 }
|
||||
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 4 }
|
||||
T{ ##peek f V int-regs 5 D 5 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 2 }
|
||||
T{ ##replace f V int-regs 2 D 3 }
|
||||
T{ ##replace f V int-regs 3 D 4 }
|
||||
T{ ##replace f V int-regs 4 D 5 }
|
||||
T{ ##replace f V int-regs 5 D 0 }
|
||||
}
|
||||
}
|
||||
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
|
||||
instructions>> first
|
||||
live-values>> assoc-empty?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##gc f V int-regs 2 V int-regs 3 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
|
||||
|
||||
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##compare-imm-branch f V int-regs 1 5 cc= }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##gc f V int-regs 2 V int-regs 3 }
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
|
||||
|
|
|
@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan
|
|||
init-mapping
|
||||
dup reverse-post-order machine-registers (linear-scan)
|
||||
spill-counts get >>spill-counts
|
||||
cfg-changed
|
||||
] with-scope ;
|
||||
|
|
|
@ -1,7 +0,0 @@
|
|||
USING: arrays compiler.cfg.linear-scan.resolve kernel
|
||||
tools.test ;
|
||||
IN: compiler.cfg.linear-scan.resolve.tests
|
||||
|
||||
[ { 1 2 3 4 5 6 } ] [
|
||||
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
|
||||
] unit-test
|
|
@ -3,6 +3,7 @@
|
|||
USING: accessors arrays assocs combinators
|
||||
combinators.short-circuit fry kernel locals
|
||||
make math sequences
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
|
||||
|
@ -30,42 +31,14 @@ IN: compiler.cfg.linear-scan.resolve
|
|||
[ resolve-value-data-flow ] with with each
|
||||
] { } make ;
|
||||
|
||||
: fork? ( from to -- ? )
|
||||
{
|
||||
[ drop successors>> length 1 >= ]
|
||||
[ nip predecessors>> length 1 = ]
|
||||
} 2&& ; inline
|
||||
|
||||
: insert-position/fork ( from to -- before after )
|
||||
nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
|
||||
|
||||
: join? ( from to -- ? )
|
||||
{
|
||||
[ drop successors>> length 1 = ]
|
||||
[ nip predecessors>> length 1 >= ]
|
||||
} 2&& ; inline
|
||||
|
||||
: insert-position/join ( from to -- before after )
|
||||
drop instructions>> dup pop 1array ;
|
||||
|
||||
: insert-position ( bb to -- before after )
|
||||
{
|
||||
{ [ 2dup fork? ] [ insert-position/fork ] }
|
||||
{ [ 2dup join? ] [ insert-position/join ] }
|
||||
} cond ;
|
||||
|
||||
: 3append-here ( seq2 seq1 seq3 -- )
|
||||
#! Mutate seq1
|
||||
swap '[ _ push-all ] bi@ ;
|
||||
|
||||
: perform-mappings ( mappings bb to -- )
|
||||
pick empty? [ 3drop ] [
|
||||
[ mapping-instructions ] 2dip
|
||||
insert-position 3append-here
|
||||
: perform-mappings ( bb to mappings -- )
|
||||
dup empty? [ 3drop ] [
|
||||
mapping-instructions <simple-block>
|
||||
insert-basic-block
|
||||
] if ;
|
||||
|
||||
: resolve-edge-data-flow ( bb to -- )
|
||||
[ compute-mappings ] [ perform-mappings ] 2bi ;
|
||||
2dup compute-mappings perform-mappings ;
|
||||
|
||||
: resolve-block-data-flow ( bb -- )
|
||||
dup successors>> [ resolve-edge-data-flow ] with each ;
|
||||
|
|
|
@ -5,6 +5,7 @@ combinators assocs arrays locals cpu.architecture
|
|||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.linearization
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
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 layouts ;
|
||||
math.partial-dispatch math.private sbufs sequences sequences.private sets
|
||||
slots.private strings strings.private tools.test vectors layouts ;
|
||||
IN: compiler.cfg.optimizer.tests
|
||||
|
||||
! Miscellaneous tests
|
||||
|
@ -31,6 +31,19 @@ IN: compiler.cfg.optimizer.tests
|
|||
[ [ 2 fixnum+ ] when 3 ]
|
||||
[ [ 2 fixnum- ] when 3 ]
|
||||
[ 10000 [ ] times ]
|
||||
[
|
||||
over integer? [
|
||||
over dup 16 <-integer-fixnum
|
||||
[ 0 >=-integer-fixnum ] [ drop f ] if [
|
||||
nip dup
|
||||
[ ] [ ] if
|
||||
] [ 2drop f ] if
|
||||
] [ 2drop f ] if
|
||||
]
|
||||
[
|
||||
pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
|
||||
set-string-nth-fast
|
||||
]
|
||||
} [
|
||||
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
||||
] each
|
||||
|
|
|
@ -29,10 +29,9 @@ SYMBOL: check-optimizer?
|
|||
! The passes that need this document it.
|
||||
[
|
||||
optimize-tail-calls
|
||||
compute-predecessors
|
||||
delete-useless-conditionals
|
||||
split-branches
|
||||
compute-predecessors
|
||||
split-branches
|
||||
stack-analysis
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
|
|
|
@ -35,6 +35,12 @@ 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
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 1 } ]
|
||||
[ 2 get successors>> first instructions>> first ]
|
||||
unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
|
||||
[ 3 get successors>> first instructions>> first ]
|
||||
unit-test
|
||||
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel sequences
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
USING: accessors assocs fry kernel sequences namespaces
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.phi-elimination
|
||||
|
||||
: insert-copy ( predecessor input output -- )
|
||||
|
@ -11,7 +12,11 @@ IN: compiler.cfg.phi-elimination
|
|||
[ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
|
||||
|
||||
: eliminate-phi-step ( bb -- )
|
||||
instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
|
||||
H{ } clone added-instructions set
|
||||
[ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ]
|
||||
[ insert-basic-blocks ]
|
||||
bi ;
|
||||
|
||||
: eliminate-phis ( cfg -- cfg' )
|
||||
dup [ eliminate-phi-step ] each-basic-block ;
|
||||
dup [ eliminate-phi-step ] each-basic-block
|
||||
cfg-changed ;
|
|
@ -0,0 +1,157 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces sequences
|
||||
compiler.cfg.instructions compiler.cfg.registers ;
|
||||
IN: compiler.cfg.renaming
|
||||
|
||||
SYMBOL: renamings
|
||||
|
||||
: rename-value ( vreg -- vreg' ) renamings get at ;
|
||||
|
||||
GENERIC: rename-insn-defs ( insn -- )
|
||||
|
||||
M: ##flushable rename-insn-defs
|
||||
[ rename-value ] change-dst
|
||||
drop ;
|
||||
|
||||
M: insn rename-insn-defs drop ;
|
||||
|
||||
GENERIC: rename-insn-uses ( insn -- )
|
||||
|
||||
M: ##effect rename-insn-uses
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##unary rename-insn-uses
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##binary rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
[ rename-value ] change-src2
|
||||
drop ;
|
||||
|
||||
M: ##binary-imm rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
drop ;
|
||||
|
||||
M: ##slot rename-insn-uses
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-slot
|
||||
drop ;
|
||||
|
||||
M: ##slot-imm rename-insn-uses
|
||||
[ rename-value ] change-obj
|
||||
drop ;
|
||||
|
||||
M: ##set-slot rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-slot
|
||||
drop ;
|
||||
|
||||
M: ##string-nth rename-insn-uses
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-index
|
||||
drop ;
|
||||
|
||||
M: ##set-string-nth-fast rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-index
|
||||
drop ;
|
||||
|
||||
M: ##set-slot-imm rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-obj
|
||||
drop ;
|
||||
|
||||
M: ##alien-getter rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##alien-setter rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-value
|
||||
drop ;
|
||||
|
||||
M: ##conditional-branch rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
[ rename-value ] change-src2
|
||||
drop ;
|
||||
|
||||
M: ##compare-imm-branch rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
drop ;
|
||||
|
||||
M: ##dispatch rename-insn-uses
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##fixnum-overflow rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
[ rename-value ] change-src2
|
||||
drop ;
|
||||
|
||||
M: insn rename-insn-uses drop ;
|
||||
|
||||
: fresh-vreg ( vreg -- vreg' )
|
||||
reg-class>> next-vreg ;
|
||||
|
||||
GENERIC: fresh-insn-temps ( insn -- )
|
||||
|
||||
M: ##write-barrier fresh-insn-temps
|
||||
[ fresh-vreg ] change-card#
|
||||
[ fresh-vreg ] change-table
|
||||
drop ;
|
||||
|
||||
M: ##unary/temp fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##allot fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##dispatch fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##slot fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##set-slot fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##string-nth fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##set-string-nth-fast fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##compare fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##compare-imm fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##compare-float fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##fixnum-mul fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp1
|
||||
[ fresh-vreg ] change-temp2
|
||||
drop ;
|
||||
|
||||
M: ##fixnum-mul-tail fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp1
|
||||
[ fresh-vreg ] change-temp2
|
||||
drop ;
|
||||
|
||||
M: ##gc fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp1
|
||||
[ fresh-vreg ] change-temp2
|
||||
drop ;
|
||||
|
||||
M: _dispatch fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: insn fresh-insn-temps drop ;
|
|
@ -1,8 +1,8 @@
|
|||
IN: compiler.cfg.stack-analysis.merge.tests
|
||||
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
|
||||
cpu.architecture make assocs
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
|
||||
compiler.cfg.debugger cpu.architecture make assocs namespaces
|
||||
sequences kernel classes ;
|
||||
|
||||
[
|
||||
|
@ -11,13 +11,15 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
<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>> values
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
merge-locs locs>vregs>> keys added-phis get values first
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -26,15 +28,16 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
[
|
||||
<state>
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
<state>
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||
] keep first instructions>> first class
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -42,15 +45,17 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
] keep first instructions>> first class
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -63,6 +68,9 @@ sequences kernel classes ;
|
|||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
@ -82,6 +90,9 @@ sequences kernel classes ;
|
|||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
|
||||
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs sequences accessors fry combinators grouping
|
||||
sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.stack-analysis.state ;
|
||||
USING: kernel assocs sequences accessors fry combinators grouping sets
|
||||
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
|
||||
IN: compiler.cfg.stack-analysis.merge
|
||||
|
||||
! XXX critical edges
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
[ nip first >>rs-height ]
|
||||
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
|
||||
|
||||
: assoc-map-values ( assoc quot -- assoc' )
|
||||
: assoc-map-keys ( assoc quot -- assoc' )
|
||||
'[ _ dip ] assoc-map ; inline
|
||||
|
||||
: translate-locs ( assoc state -- assoc' )
|
||||
'[ _ translate-loc ] assoc-map-values ;
|
||||
'[ _ translate-loc ] assoc-map-keys ;
|
||||
|
||||
: untranslate-locs ( assoc state -- assoc' )
|
||||
'[ _ untranslate-loc ] assoc-map-values ;
|
||||
'[ _ untranslate-loc ] assoc-map-keys ;
|
||||
|
||||
: collect-locs ( loc-maps states -- assoc )
|
||||
! assoc maps locs to sequences
|
||||
|
@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
: insert-peek ( predecessor loc state -- vreg )
|
||||
'[ _ _ translate-loc ^^peek ] add-instructions ;
|
||||
|
||||
SYMBOL: added-phis
|
||||
|
||||
: add-phi-later ( inputs -- vreg )
|
||||
[ int-regs next-vreg dup ] dip 2array added-phis get push ;
|
||||
|
||||
: 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? [ nip first ] [ zip ^^phi ] if ;
|
||||
dup all-equal? [ first ] [ add-phi-later ] if ;
|
||||
|
||||
:: merge-locs ( state predecessors states -- state )
|
||||
states [ locs>vregs>> ] map states collect-locs
|
||||
|
@ -77,30 +80,35 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
over translate-locs
|
||||
>>changed-locs ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
:: insert-phis ( bb -- )
|
||||
bb predecessors>> :> predecessors
|
||||
[
|
||||
added-phis get [| dst inputs |
|
||||
dst predecessors inputs zip ##phi
|
||||
] assoc-each
|
||||
] V{ } make bb instructions>> over push-all
|
||||
bb (>>instructions) ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
2drop <state>
|
||||
:: multiple-predecessors ( bb states -- state )
|
||||
states [ not ] any? [
|
||||
<state>
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
] [
|
||||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-ds-heights ]
|
||||
[ merge-rs-heights ]
|
||||
[ merge-locs ]
|
||||
[ nip merge-actual-locs ]
|
||||
[ nip merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
[
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
bb predecessors>> :> predecessors
|
||||
state new
|
||||
predecessors states merge-ds-heights
|
||||
predecessors states merge-rs-heights
|
||||
predecessors states merge-locs
|
||||
states merge-actual-locs
|
||||
states merge-changed-locs
|
||||
bb insert-basic-blocks
|
||||
bb insert-phis
|
||||
] with-scope
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
! If any states are poisoned, save all registers
|
||||
! to the stack in each branch
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
|
|
|
@ -99,7 +99,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
! Correct height tracking
|
||||
[ t ] [
|
||||
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
|
||||
reverse-post-order 3 swap nth
|
||||
reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
|
||||
2array { D 1 D 0 } set=
|
||||
] unit-test
|
||||
|
@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> second loc>>
|
||||
3 get successors>> first instructions>> first loc>>
|
||||
] unit-test
|
||||
|
||||
! Do inserted ##peeks reference the correct stack location if
|
||||
|
@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
||||
|
||||
! Missing ##replace
|
||||
|
@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
! Inserted ##peeks reference the wrong stack location
|
||||
[ t ] [
|
||||
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
|
||||
eliminate-dead-code reverse-post-order 3 swap nth
|
||||
eliminate-dead-code reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter [ loc>> ] map
|
||||
{ R 0 D 0 D 1 } set=
|
||||
{ D 0 D 1 } set=
|
||||
] unit-test
|
||||
|
||||
[ D 0 ] [
|
||||
|
@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||
sets make combinators
|
||||
sets make combinators dlists deques
|
||||
compiler.cfg
|
||||
compiler.cfg.copy-prop
|
||||
compiler.cfg.def-use
|
||||
|
@ -10,9 +10,14 @@ compiler.cfg.registers
|
|||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.stack-analysis.merge ;
|
||||
compiler.cfg.stack-analysis.merge
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( bb -- ) work-list get push-front ;
|
||||
|
||||
: redundant-replace? ( vreg loc -- ? )
|
||||
dup state get untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
@ -60,9 +65,6 @@ UNION: sync-if-back-edge
|
|||
##dispatch
|
||||
##loop-entry ;
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ > ;
|
||||
|
||||
: sync-state? ( -- ? )
|
||||
basic-block get successors>>
|
||||
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
|
||||
|
@ -140,10 +142,21 @@ SYMBOLS: state-in state-out ;
|
|||
] 2bi
|
||||
] V{ } make >>instructions drop ;
|
||||
|
||||
: visit-successors ( bb -- )
|
||||
dup successors>> [
|
||||
2dup back-edge? [ 2drop ] [ nip add-to-work-list ] if
|
||||
] with each ;
|
||||
|
||||
: process-work-list ( -- )
|
||||
work-list get [ visit-block ] slurp-deque ;
|
||||
|
||||
: stack-analysis ( cfg -- cfg' )
|
||||
[
|
||||
<hashed-dlist> work-list set
|
||||
H{ } clone copies set
|
||||
H{ } clone state-in set
|
||||
H{ } clone state-out set
|
||||
dup [ visit-block ] each-basic-block
|
||||
dup [ add-to-work-list ] each-basic-block
|
||||
process-work-list
|
||||
cfg-changed
|
||||
] with-scope ;
|
||||
|
|
|
@ -5,7 +5,8 @@ namespaces sequences fry combinators
|
|||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.instructions ;
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.tco
|
||||
|
||||
! Tail call optimization. You must run compute-predecessors after this
|
||||
|
@ -82,4 +83,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn
|
|||
: optimize-tail-calls ( cfg -- cfg' )
|
||||
dup cfg set
|
||||
dup [ optimize-tail-call ] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
|
@ -1,7 +1,8 @@
|
|||
! 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 ;
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.useless-conditionals
|
||||
|
||||
: delete-conditional? ( bb -- ? )
|
||||
|
@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
|
|||
dup [
|
||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math layouts make sequences combinators
|
||||
cpu.architecture namespaces compiler.cfg
|
||||
compiler.cfg.instructions ;
|
||||
USING: accessors assocs combinators combinators.short-circuit
|
||||
compiler.cfg compiler.cfg.instructions cpu.architecture kernel
|
||||
layouts locals make math namespaces sequences sets vectors fry ;
|
||||
IN: compiler.cfg.utilities
|
||||
|
||||
: value-info-small-fixnum? ( value-info -- ? )
|
||||
|
@ -33,7 +33,53 @@ IN: compiler.cfg.utilities
|
|||
building off
|
||||
basic-block off ;
|
||||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##call ##branch begin-basic-block ;
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ >= ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
! assoc mapping predecessors to sequences
|
||||
SYMBOL: added-instructions
|
||||
|
||||
: add-instructions ( predecessor quot -- )
|
||||
[
|
||||
added-instructions get
|
||||
[ drop V{ } clone ] cache
|
||||
building
|
||||
] dip with-variable ; inline
|
||||
|
||||
:: insert-basic-block ( from to bb -- )
|
||||
bb from 1vector >>predecessors drop
|
||||
bb to 1vector >>successors drop
|
||||
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
|
||||
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
|
||||
|
||||
: <simple-block> ( insns -- bb )
|
||||
<basic-block>
|
||||
swap >vector
|
||||
\ ##branch new-insn over push
|
||||
>>instructions ;
|
||||
|
||||
: insert-basic-blocks ( bb -- )
|
||||
[ added-instructions get ] dip
|
||||
'[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
|
||||
|
|
|
@ -1,69 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs sequences kernel accessors
|
||||
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
|
||||
IN: compiler.cfg.value-numbering.propagate
|
||||
|
||||
! If two vregs compute the same value, replace references to
|
||||
! the latter with the former.
|
||||
|
||||
: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
|
||||
|
||||
GENERIC: propagate ( insn -- insn )
|
||||
|
||||
M: ##effect propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##unary propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##binary propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: ##binary-imm propagate
|
||||
[ resolve ] change-src1 ;
|
||||
|
||||
M: ##slot propagate
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-slot ;
|
||||
|
||||
M: ##slot-imm propagate
|
||||
[ resolve ] change-obj ;
|
||||
|
||||
M: ##set-slot propagate
|
||||
call-next-method
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-slot ;
|
||||
|
||||
M: ##string-nth propagate
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-index ;
|
||||
|
||||
M: ##set-slot-imm propagate
|
||||
call-next-method
|
||||
[ resolve ] change-obj ;
|
||||
|
||||
M: ##alien-getter propagate
|
||||
call-next-method
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##alien-setter propagate
|
||||
call-next-method
|
||||
[ resolve ] change-value ;
|
||||
|
||||
M: ##conditional-branch propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: ##compare-imm-branch propagate
|
||||
[ resolve ] change-src1 ;
|
||||
|
||||
M: ##dispatch propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##fixnum-overflow propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: insn propagate ;
|
|
@ -1 +0,0 @@
|
|||
Propagation pass to update code after value numbering
|
|
@ -2,7 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors locals combinators combinators.short-circuit arrays
|
||||
fry kernel layouts math namespaces sequences cpu.architecture
|
||||
math.bitwise compiler.cfg.hats compiler.cfg.instructions
|
||||
math.bitwise
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.value-numbering.expressions
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.simplify ;
|
||||
|
@ -49,9 +52,12 @@ M: insn rewrite ;
|
|||
[ src2>> tag-mask get bitand 0 = ]
|
||||
} 1&& ; inline
|
||||
|
||||
: tagged>constant ( n -- n' )
|
||||
tag-bits get neg shift ; inline
|
||||
|
||||
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
|
||||
[ src1>> vreg>expr in1>> vn>vreg ]
|
||||
[ src2>> tag-bits get neg shift ]
|
||||
[ src2>> tagged>constant ]
|
||||
[ cc>> ]
|
||||
tri ; inline
|
||||
|
||||
|
@ -77,13 +83,19 @@ M: ##compare-imm-branch rewrite
|
|||
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 ;
|
||||
: vreg-small-constant? ( vreg -- ? )
|
||||
vreg>expr {
|
||||
[ constant-expr? ]
|
||||
[ value>> small-enough? ]
|
||||
} 1&& ;
|
||||
|
||||
M: ##compare rewrite
|
||||
dup [ src1>> ] [ src2>> ] bi
|
||||
[ vreg-small-constant? ] bi@ 2array {
|
||||
{ { f t } [ f >compare-imm ] }
|
||||
{ { t f } [ t >compare-imm ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
:: >compare-imm-branch ( insn swap? -- insn' )
|
||||
insn src1>>
|
||||
|
@ -91,13 +103,13 @@ M: ##compare-imm-branch rewrite
|
|||
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 ;
|
||||
M: ##compare-branch rewrite
|
||||
dup [ src1>> ] [ src2>> ] bi
|
||||
[ vreg-small-constant? ] bi@ 2array {
|
||||
{ { f t } [ f >compare-imm-branch ] }
|
||||
{ { t f } [ t >compare-imm-branch ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: rewrite-redundant-comparison? ( insn -- ? )
|
||||
{
|
||||
|
@ -197,18 +209,20 @@ 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? [
|
||||
: new-arithmetic ( obj op -- )
|
||||
[
|
||||
[ dst>> ]
|
||||
[ src1>> ]
|
||||
[ src2>> vreg>constant ] tri \ ##add-imm new-insn
|
||||
dup number-values
|
||||
] when ;
|
||||
[ src2>> vreg>constant ] tri
|
||||
] dip new-insn dup number-values ; inline
|
||||
|
||||
M: ##sub rewrite constant-fold ;
|
||||
: rewrite-arithmetic ( insn op -- ? )
|
||||
over src2>> vreg-small-constant? [
|
||||
new-arithmetic constant-fold
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
M: ##add rewrite \ ##add-imm rewrite-arithmetic ;
|
||||
|
||||
M: ##sub rewrite \ ##sub-imm rewrite-arithmetic ;
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs biassocs classes kernel math accessors
|
||||
sorting sets sequences
|
||||
sorting sets sequences fry
|
||||
compiler.cfg.local
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.renaming
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.expressions
|
||||
compiler.cfg.value-numbering.propagate
|
||||
compiler.cfg.value-numbering.simplify
|
||||
compiler.cfg.value-numbering.rewrite ;
|
||||
IN: compiler.cfg.value-numbering
|
||||
|
@ -19,8 +19,18 @@ IN: compiler.cfg.value-numbering
|
|||
init-expressions
|
||||
number-input-values ;
|
||||
|
||||
: vreg>vreg-mapping ( -- assoc )
|
||||
vregs>vns get [ keys ] keep
|
||||
'[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
|
||||
|
||||
: rename-uses ( insns -- )
|
||||
vreg>vreg-mapping renamings [
|
||||
[ rename-insn-uses ] each
|
||||
] with-variable ;
|
||||
|
||||
: value-numbering-step ( insns -- insns' )
|
||||
[ [ number-values ] [ rewrite propagate ] bi ] map ;
|
||||
[ [ number-values ] [ rewrite ] bi ] map
|
||||
dup rename-uses ;
|
||||
|
||||
: value-numbering ( cfg -- cfg' )
|
||||
[ init-value-numbering ] [ value-numbering-step ] local-optimization ;
|
||||
|
|
|
@ -4,9 +4,14 @@ USING: accessors assocs alien alien.c-types arrays strings
|
|||
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
||||
kernel kernel.private math memory namespaces make sequences
|
||||
words system layouts combinators math.order fry locals
|
||||
compiler.constants compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
|
||||
compiler.constants
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.codegen
|
||||
compiler.codegen.fixup ;
|
||||
IN: cpu.x86
|
||||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
|
|
@ -120,7 +120,7 @@ IN: math.matrices
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
|
||||
: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
|
||||
|
||||
: proj ( v u -- w )
|
||||
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors sequences sequences.private growable
|
||||
USING: accessors alien.c-types functors sequences sequences.private growable
|
||||
prettyprint.custom kernel words classes math parser ;
|
||||
QUALIFIED: vectors.functor
|
||||
IN: specialized-vectors.functor
|
||||
|
@ -21,6 +21,8 @@ V A <A> vectors.functor:define-vector
|
|||
|
||||
M: V contract 2drop ;
|
||||
|
||||
M: V byte-length underlying>> byte-length ;
|
||||
|
||||
M: V pprint-delims drop \ V{ \ } ;
|
||||
|
||||
M: V >pprint-sequence ;
|
||||
|
|
|
@ -31,19 +31,20 @@ M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
|
|||
cannot-annotate-twice
|
||||
] when ;
|
||||
|
||||
GENERIC# (annotate) 1 ( word quot -- )
|
||||
|
||||
M: generic (annotate)
|
||||
[ "methods" word-prop values ] dip '[ _ (annotate) ] each ;
|
||||
|
||||
M: word (annotate)
|
||||
[ check-annotate-twice ] dip
|
||||
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip
|
||||
call( old -- new ) define ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# annotate 1 ( word quot -- )
|
||||
|
||||
M: generic annotate
|
||||
[ "methods" word-prop values ] dip '[ _ annotate ] each ;
|
||||
|
||||
M: word annotate
|
||||
[ check-annotate-twice ] dip
|
||||
[
|
||||
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip
|
||||
call( old -- new ) define
|
||||
] with-compilation-unit ;
|
||||
: annotate ( word quot -- )
|
||||
[ (annotate) ] with-compilation-unit ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
@ -163,9 +163,11 @@ M: world resize-world
|
|||
M: world (>>dim)
|
||||
[ call-next-method ]
|
||||
[
|
||||
dup handle>>
|
||||
[ [ set-gl-context ] [ resize-world ] bi ]
|
||||
[ drop ] if
|
||||
dup active?>> [
|
||||
dup handle>>
|
||||
[ [ set-gl-context ] [ resize-world ] bi ]
|
||||
[ drop ] if
|
||||
] [ drop ] if
|
||||
] bi ;
|
||||
|
||||
GENERIC: draw-world* ( world -- )
|
||||
|
|
|
@ -26,7 +26,7 @@ HELP: assoc>query
|
|||
"USING: io urls.encoding ;"
|
||||
"{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
|
||||
"assoc>query print"
|
||||
"from=Lead&to=Gold%2c%20please"
|
||||
"from=Lead&to=Gold%2C%20please"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -290,4 +290,7 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
|
|||
USE: make
|
||||
|
||||
[ { "a" 1 "b" 1 "c" } ]
|
||||
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
|
||||
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
|
||||
|
||||
[ t ] [ 0 array-capacity? ] unit-test
|
||||
[ f ] [ -1 array-capacity? ] unit-test
|
|
@ -0,0 +1,44 @@
|
|||
USING: bson.reader bson.writer byte-arrays io.encodings.binary
|
||||
io.streams.byte-array tools.test literals calendar kernel math ;
|
||||
|
||||
IN: bson.tests
|
||||
|
||||
: turnaround ( value -- value )
|
||||
assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
|
||||
|
||||
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
|
||||
|
||||
[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
|
||||
[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
|
||||
|
||||
[ H{ { "a list" { 1 2.234 "hello world" } } } ]
|
||||
[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test
|
||||
|
||||
[ H{ { "a quotation" [ 1 2 + ] } } ]
|
||||
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
|
||||
|
||||
[ H{ { "a date" T{ timestamp { year 2009 }
|
||||
{ month 7 }
|
||||
{ day 11 }
|
||||
{ hour 9 }
|
||||
{ minute 8 }
|
||||
{ second 40+77/1000 } } } }
|
||||
]
|
||||
[ H{ { "a date" T{ timestamp { year 2009 }
|
||||
{ month 7 }
|
||||
{ day 11 }
|
||||
{ hour 11 }
|
||||
{ minute 8 }
|
||||
{ second 40+15437/200000 }
|
||||
{ gmt-offset T{ duration { hour 2 } } } } } } turnaround
|
||||
] unit-test
|
||||
|
||||
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
|
||||
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
|
||||
{ "quot" [ 1 2 + ] } }
|
||||
]
|
||||
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
|
||||
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
|
||||
{ "quot" [ 1 2 + ] } } turnaround ] unit-test
|
||||
|
||||
|
|
@ -1,18 +1,23 @@
|
|||
! Copyright (C) 2009 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.libraries alien.syntax ;
|
||||
USING: alien.libraries alien.syntax system sequences combinators kernel ;
|
||||
|
||||
IN: llvm.core
|
||||
|
||||
<<
|
||||
|
||||
"LLVMSystem" "/usr/local/lib/libLLVMSystem.dylib" "cdecl" add-library
|
||||
: add-llvm-library ( name -- )
|
||||
dup
|
||||
{
|
||||
{ [ os macosx? ] [ "/usr/local/lib/lib" ".dylib" surround ] }
|
||||
{ [ os windows? ] [ ".dll" append ] }
|
||||
{ [ os unix? ] [ "lib" ".so" surround ] }
|
||||
} cond "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
|
||||
"LLVMSystem" add-llvm-library
|
||||
"LLVMSupport" add-llvm-library
|
||||
"LLVMCore" add-llvm-library
|
||||
"LLVMBitReader" add-llvm-library
|
||||
|
||||
>>
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -5,29 +5,18 @@ 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
|
||||
"LLVMExecutionEngine" add-llvm-library
|
||||
"LLVMTarget" add-llvm-library
|
||||
"LLVMAnalysis" add-llvm-library
|
||||
"LLVMipa" add-llvm-library
|
||||
"LLVMTransformUtils" add-llvm-library
|
||||
"LLVMScalarOpts" add-llvm-library
|
||||
"LLVMCodeGen" add-llvm-library
|
||||
"LLVMAsmPrinter" add-llvm-library
|
||||
"LLVMSelectionDAG" add-llvm-library
|
||||
"LLVMX86CodeGen" add-llvm-library
|
||||
"LLVMJIT" add-llvm-library
|
||||
"LLVMInterpreter" add-llvm-library
|
||||
|
||||
>>
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -1 +1,2 @@
|
|||
bindings
|
||||
unportable
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -76,7 +76,7 @@ HELP: count
|
|||
|
||||
HELP: create-collection
|
||||
{ $values
|
||||
{ "name" "collection name" }
|
||||
{ "name/collection" "collection name" }
|
||||
}
|
||||
{ $description "Creates a new collection with the given name." } ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue