steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into inlinec 

* master: (39 commits)
  Revert "Remove unused vocabulary" -- committed patch from the wrong machine
  Remove unused vocabulary
  Fixing some test failures after url.encoding change
  FUEL: Font lock/indentation for M::.
  replace 2array "." join with "." glue
  contributors: exclude merges to make patch counts more reasonable
  alien.libraries: add remove-library word, fix dlclose and dll-valid? VM primitives
  alien.libraries: add dispose method for library tuple, and remove-library word; add-library first calls remove-library to properly close the library when reloading
  changed single byte writes to write1
  removed usages of sprintf
  fixed signed number decoding problem
  added >upper to push-utf8 to conform with RFC 3986 section 2.1. recommendation
  io.launcher: unnecessary word
  compiler.cfg.optimizer: fix irrelevant test
  compiler.tree.propagation: better length propagation
  compiler.cfg.linear-scan: fixing unit tests
  compiler.cfg.linear-scan: more code cleanups, and working on split-to-fit algorithm
  compiler.cfg.linear-scan: code cleanups
  compiler.cfg.linear-scan: split off parallel mapping code from resolve pass, use it in assignment pass to resolve parallel copies
  updated llvm.invoker test to use install-bc
  ...
db4
Jeremy Hughes 2009-07-10 13:03:07 +12:00
parent 8281c2fb55 bb701bed7e
commit 289c963dd2
58 changed files with 1593 additions and 527 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
basis/alien/libraries/libraries-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax assocs help.markup
help.syntax io.backend kernel namespaces ;
help.syntax io.backend kernel namespaces strings ;
IN: alien.libraries
HELP: <library>
@ -15,7 +15,7 @@ HELP: libraries
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
{ $values { "name" "a string" } { "library" assoc } }
{ $values { "name" string } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
@ -40,11 +40,11 @@ HELP: dlclose ( dll -- )
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
{ $values { "name" string } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
$nl
@ -59,9 +59,14 @@ $nl
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
HELP: remove-library
{ $values { "name" string } }
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
ARTICLE: "loading-libs" "Loading native libraries"
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
{ $subsection add-library }
{ $subsection remove-library }
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsection load-library }
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;

10
basis/alien/libraries/libraries-tests.factor Normal file
View File

@ -0,0 +1,10 @@
IN: alien.libraries.tests
USING: alien.libraries alien.syntax tools.test kernel ;
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
[ "fdasfsf" dll-valid? drop ] must-fail

14
basis/alien/libraries/libraries.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
@ -21,5 +22,12 @@ TUPLE: library path abi dll ;
: load-library ( name -- dll )
library dup [ dll>> ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
M: dll dispose dlclose ;
M: library dispose dll>> [ dispose ] when* ;
: remove-library ( name -- )
libraries get delete-at* [ dispose ] [ drop ] if ;
: add-library ( name path abi -- )
<library> swap libraries get [ delete-at ] [ set-at ] 2bi ;

20
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -28,16 +28,30 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? )
second 0 = ; inline
: split-to-fit ( new n -- before after )
split-interval
[ [ compute-start/end ] bi@ ]
[ >>split-next drop ]
[ ]
2tri ;
: register-partially-available ( new result -- )
[ second split-before-use ] keep
'[ _ register-available ] [ add-unhandled ] bi* ;
{
{ [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] }
[
[ second 1 - split-to-fit ] keep
'[ _ register-available ] [ add-unhandled ] bi*
]
} cond ;
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
[ register-partially-available ]
! [ register-partially-available ]
[ drop assign-blocked-register ]
} cond
] if ;

74
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ;
} 2cleave ;
: assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to drop ;
dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
: assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ;
@ -80,10 +80,12 @@ ERROR: bad-live-ranges interval ;
[ add-unhandled ]
} cleave ;
: split-intersecting? ( live-interval new reg -- ? )
{ [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
: split-live-out ( live-interval -- )
: spill-live-out ( live-interval -- )
! The interval has no more usages after the spill location. This
! means it is the first child of an interval that was split. We
! spill the value and let the resolve pass insert a reload later.
{
[ trim-before-ranges ]
[ compute-start/end ]
@ -91,7 +93,13 @@ ERROR: bad-live-ranges interval ;
[ add-handled ]
} cleave ;
: split-live-in ( live-interval -- )
: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ;
: spill-live-in ( live-interval -- )
! The interval does not have any usages before the spill location.
! This means it is the second child of an interval that was
! split. We reload the value and let the resolve pass insert a
! split later.
{
[ trim-after-ranges ]
[ compute-start/end ]
@ -99,40 +107,48 @@ ERROR: bad-live-ranges interval ;
[ 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 ] }
: spill ( live-interval n -- )
{
{ [ 2dup spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup spill-live-in? ] [ drop spill-live-in ] }
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ;
: (split-intersecting-active) ( active new -- )
[ drop delete-active ]
[ (split-intersecting) ] 2bi ;
:: spill-intersecting-active ( new reg -- )
! If there is an active interval using 'reg' (there should be at
! most one) are split and spilled and removed from the inactive
! set.
new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
'[ _ delete-nth new start>> spill ] [ 2drop ] if ;
: split-intersecting-active ( new reg -- )
[ [ vreg>> active-intervals-for ] keep ] dip
[ '[ _ _ split-intersecting? ] filter ] 2keep drop
'[ _ (split-intersecting-active) ] each ;
:: spill-intersecting-inactive ( new reg -- )
! Any inactive intervals using 'reg' are split and spilled
! and removed from the inactive set.
new vreg>> inactive-intervals-for [
dup reg>> reg = [
dup new intervals-intersect? [
new start>> spill f
] [ drop t ] if
] [ drop t ] if
] filter-here ;
: (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 ]
: spill-intersecting ( new reg -- )
! Split and spill all active and inactive intervals
! which intersect 'new' and use 'reg'.
[ spill-intersecting-active ]
[ spill-intersecting-inactive ]
2bi ;
: spill-available ( new pair -- )
[ first split-intersecting ] [ register-available ] 2bi ;
! A register would become fully available if all
! active and inactive intervals using it were split
! and spilled.
[ first spill-intersecting ] [ register-available ] 2bi ;
: spill-partially-available ( new pair -- )
! A register would be available for part of the new
! interval's lifetime if all active and inactive intervals
! using that register were split and spilled.
[ second 1 - split-and-spill add-unhandled ] keep
spill-available ;

20
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

@ -61,23 +61,3 @@ ERROR: splitting-atomic-interval ;
after split-after ;
HINTS: split-interval live-interval object ;
: split-between-blocks ( new n -- before after )
split-interval
2dup [ compute-start/end ] bi@ ;
: insert-use-for-copy ( seq n -- seq' )
[ '[ _ < ] filter ]
[ nip dup 1 + 2array ]
[ 1 + '[ _ > ] filter ]
2tri 3append ;
: split-before-use ( new n -- before after )
1 -
2dup swap covers? [
[ '[ _ insert-use-for-copy ] change-uses ] keep
split-between-blocks
2dup >>split-next drop
] [
split-between-blocks
] if ;

37
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -8,6 +8,7 @@ compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.mapping
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
@ -42,16 +43,11 @@ SYMBOL: register-live-outs
H{ } clone register-live-outs set
init-unhandled ;
: insert-spill ( live-interval -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ spill-to>> ]
[ end>> ]
} cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
dup spill-to>> [
[ reg>> ] [ spill-to>> <spill-slot> ] [ vreg>> reg-class>> ] tri
register->memory
] [ drop ] if ;
: first-split ( live-interval -- live-interval' )
dup split-before>> [ first-split ] [ ] ?if ;
@ -59,22 +55,19 @@ SYMBOL: register-live-outs
: next-interval ( live-interval -- live-interval' )
split-next>> first-split ;
: insert-copy ( live-interval -- )
{
[ next-interval reg>> ]
[ reg>> ]
[ vreg>> reg-class>> ]
[ end>> ]
} cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- )
dup split-next>> [ insert-copy ] [ drop ] if ;
dup split-next>> [
[ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
register->register
] [ drop ] if ;
: expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[
dup end>> _ <
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ;
[
[ pending-intervals get ] dip '[
dup end>> _ <
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here
] { } make mapping-instructions % ;
: insert-reload ( live-interval -- )
{

56
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -1,7 +1,7 @@
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 strings strings.private
math.order grouping strings strings.private classes
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
@ -153,56 +153,6 @@ check-numbering? on
} 10 split-for-spill [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ 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 } }
{ ranges V{ T{ live-range f 5 5 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 5 split-before-use [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ 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 10 }
{ uses V{ 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
] [
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{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -225,7 +175,7 @@ check-numbering? on
{ 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@
} 4 split-to-fit [ f >>split-next ] bi@
] unit-test
[
@ -1847,8 +1797,6 @@ test-diamond
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
USING: classes ;
[ ] [
1 get instructions>> first regs>> V int-regs 0 swap at
2 get instructions>> first regs>> V int-regs 1 swap at assert=

4
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -10,7 +10,8 @@ compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.resolve ;
compiler.cfg.linear-scan.resolve
compiler.cfg.linear-scan.mapping ;
IN: compiler.cfg.linear-scan
! References:
@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan
: linear-scan ( cfg -- cfg' )
[
init-mapping
dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
] with-scope ;

145
basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor Normal file
View File

@ -0,0 +1,145 @@
USING: compiler.cfg.instructions
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.mapping cpu.architecture kernel
namespaces tools.test ;
IN: compiler.cfg.linear-scan.mapping.tests
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
init-mapping
[
{
T{ _copy { dst 5 } { src 4 } { class int-regs } }
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{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 2 } { class int-regs } { n 10 } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
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 10 } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { 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{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ }
] [
{
T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 3 } { class int-regs } { n 4 } }
T{ _reload { dst 2 } { class int-regs } { n 1 } }
}
] [
{
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{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { 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 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
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 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test

148
basis/compiler/cfg/linear-scan/mapping/mapping.factor Normal file
View File

@ -0,0 +1,148 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
combinators compiler.cfg.instructions
compiler.cfg.linear-scan.allocation.state fry hashtables kernel
locals make namespaces parser sequences sets words ;
IN: compiler.cfg.linear-scan.mapping
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 ]
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
>>
OPERATION: register->memory
OPERATION: memory->register
OPERATION: register->register
! 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= ;
GENERIC: >insn ( operation -- )
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
: start? ( operations -- pair )
from-reg tos get key? not ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
bi ;
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
[ (trace-chain) ] [ 2drop ] if
] [
drop
] if ;
: trace-chain ( obj -- seq )
[
dup ,
dup dup associate (trace-chain)
] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
ERROR: resolve-error ;
: split-cycle ( operations -- chain spilled-operation )
unclip [
[ 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
] [
[ reg-class>> spill-temp <spill-slot> ]
[ to>> ]
[ reg-class>> ]
tri \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
dup length {
{ 1 [ ] }
[ drop break-cycle-n ]
} case ;
: (group-cycles) ( seq -- )
[
dup set-tos/froms
unclip trace-chain
[ diff ] keep , (group-cycles)
] unless-empty ;
: group-cycles ( seq -- seqs )
[ (group-cycles) ] { } make ;
: remove-dead-mappings ( seq -- seq' )
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
: parallel-mappings ( operations -- seq )
[
[ independent-assignment? not ] partition %
[ start? not ] partition
[ trace-chain ] map concat dup %
diff group-cycles [ break-cycle ] map concat %
] { } make remove-dead-mappings ;
: mapping-instructions ( mappings -- insns )
[ { } ] [
[
[ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope
] if-empty ;
: init-mapping ( -- )
H{ } clone spill-temps set ;

151
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
View File

@ -1,154 +1,7 @@
USING: accessors arrays classes compiler.cfg
compiler.cfg.debugger compiler.cfg.instructions
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 ;
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
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 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{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 2 } { class int-regs } { n 10 } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
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 10 } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { 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{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ }
] [
{
T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 3 } { class int-regs } { n 4 } }
T{ _reload { dst 2 } { class int-regs } { n 1 } }
}
] [
{
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{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { 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 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
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 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test

150
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -1,36 +1,13 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.allocation.state
compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals
make math sequences
compiler.cfg.instructions
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.mapping 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 ]
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
>>
OPERATION: register->memory
OPERATION: memory->register
OPERATION: register->register
! 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= ;
: add-mapping ( from to reg-class -- )
over spill-slot? [
pick spill-slot?
@ -53,118 +30,6 @@ OPERATION: register->register
[ resolve-value-data-flow ] with with each
] { } make ;
GENERIC: >insn ( operation -- )
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
: start? ( operations -- pair )
from-reg tos get key? not ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
bi ;
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
[ (trace-chain) ] [ 2drop ] if
] [
drop
] if ;
: trace-chain ( obj -- seq )
[
dup ,
dup dup associate (trace-chain)
] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
ERROR: resolve-error ;
: split-cycle ( operations -- chain spilled-operation )
unclip [
[ 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
] [
[ reg-class>> spill-temp <spill-slot> ]
[ to>> ]
[ reg-class>> ]
tri \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
dup length {
{ 1 [ ] }
[ drop break-cycle-n ]
} case ;
: (group-cycles) ( seq -- )
[
dup set-tos/froms
unclip trace-chain
[ diff ] keep , (group-cycles)
] unless-empty ;
: group-cycles ( seq -- seqs )
[ (group-cycles) ] { } make ;
: remove-dead-mappings ( seq -- seq' )
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
: parallel-mappings ( operations -- seq )
[
[ independent-assignment? not ] partition %
[ start? not ] partition
[ trace-chain ] map concat dup %
diff group-cycles [ break-cycle ] map concat %
] { } make remove-dead-mappings ;
: mapping-instructions ( mappings -- insns )
[
[ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope ;
: fork? ( from to -- ? )
{
[ drop successors>> length 1 >= ]
@ -206,5 +71,4 @@ ERROR: resolve-error ;
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
H{ } clone spill-temps set
[ resolve-block-data-flow ] each ;

15
basis/compiler/cfg/optimizer/optimizer-tests.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@ 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 ;
slots.private strings tools.test vectors layouts ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
@ -35,10 +35,11 @@ IN: compiler.cfg.optimizer.tests
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each
[ t ]
[
cell 8 = [
[ t ]
[
HEX: 7fff fixnum-bitand 13 fixnum-shift-fast
112 23 fixnum-shift-fast fixnum+fast
] test-mr first instructions>> [ ##add? ] any?
] unit-test
[
1 50 fixnum-shift-fast fixnum+fast
] test-mr first instructions>> [ ##add? ] any?
] unit-test
] when

17
basis/compiler/tree/propagation/info/info.factor
View File

@ -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: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators
namespaces sequences words combinators byte-arrays strings
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
@ -66,12 +66,17 @@ DEFER: <literal-info>
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ;
UNION: fixed-length array byte-array string ;
: init-literal-info ( info -- info )
[-inf,inf] >>interval
dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip
dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
] if ; inline
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
{ [ dup fixed-length? ] [ length <literal-info> >>length ] }
[ drop ]
} cond ; inline
: init-value-info ( info -- info )
dup literal?>> [

10
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -331,6 +331,16 @@ cell-bits 32 = [
[ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
] unit-test
[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
[ V{ 3 } ] [ [ 3 <byte-array> length ] final-literals ] unit-test
[ V{ 3 } ] [ [ 3 f <string> length ] final-literals ] unit-test
! Slot propagation
TUPLE: prop-test-tuple { x integer } ;

2
basis/farkup/farkup-tests.factor
View File

@ -128,7 +128,7 @@ link-no-follow? off
[ "<p><a href=\"a\">a</a> <a href=\"b\">c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
[ "<p><a href=\"C%2b%2b\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p><a href=\"C%2B%2B\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test

2
basis/http/client/client-tests.factor
View File

@ -16,6 +16,7 @@ namespaces urls ;
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
{ redirects 10 }
}
] [
"http://www.apple.com/index.html"
@ -29,6 +30,7 @@ namespaces urls ;
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
{ redirects 10 }
}
] [
"https://www.amazon.com/index.html"

7
basis/http/client/client.factor
View File

@ -12,8 +12,6 @@ IN: http.client
ERROR: too-many-redirects ;
CONSTANT: max-redirects 10
<PRIVATE
: write-request-line ( request -- request )
@ -79,7 +77,7 @@ SYMBOL: redirects
:: 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
@ -116,7 +114,8 @@ SYMBOL: redirects
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 ]
[ ]

2
basis/http/client/debugger/debugger.factor
View File

@ -1,7 +1,7 @@
! 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

1
basis/http/http-docs.factor
View File

@ -17,6 +17,7 @@ $nl
{ { $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>

2
basis/http/http-tests.factor
View File

@ -33,6 +33,7 @@ blah
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
{ post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
{ cookies V{ } }
{ redirects 10 }
}
] [
read-request-test-1 lf>crlf [
@ -70,6 +71,7 @@ Host: www.sex.com
{ version "1.1" }
{ header H{ { "host" "www.sex.com" } } }
{ cookies V{ } }
{ redirects 10 }
}
] [
read-request-test-2 lf>crlf [

8
basis/http/http.factor
View File

@ -10,6 +10,8 @@ http.parsers
base64 ;
IN: http
CONSTANT: max-redirects 10
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] produce nip ;
@ -137,7 +139,8 @@ url
version
header
post-data
cookies ;
cookies
redirects ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
@ -154,7 +157,8 @@ cookies ;
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 ;

2
basis/io/launcher/launcher.factor
View File

@ -280,5 +280,3 @@ M: output-process-error error.
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;

2
basis/urls/encoding/encoding.factor
View File

@ -37,7 +37,7 @@ IN: urls.encoding
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ;
[ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ;
PRIVATE>

4
core/alien/alien-tests.factor
View File

@ -71,10 +71,6 @@ cell 8 = [
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
SYMBOL: initialize-test
f initialize-test set-global

3
core/hashtables/hashtables-tests.factor
View File

@ -176,3 +176,6 @@ H{ } "x" set
[ 1 ] [ "h" get assoc-size ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test

15
extra/bson/reader/reader.factor
View File

@ -1,6 +1,6 @@
USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
sequences serialize arrays calendar io.encodings ;
USING: accessors assocs bson.constants calendar fry io io.binary
io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
sequences serialize ;
FROM: kernel.private => declare ;
FROM: io.encodings.private => (read-until) ;
@ -44,20 +44,17 @@ GENERIC: element-read ( type -- cont? )
GENERIC: element-data-read ( type -- object )
GENERIC: element-binary-read ( length type -- object )
: byte-array>number ( seq -- number )
byte-array>bignum >integer ; inline
: get-state ( -- state )
state get ; inline
: read-int32 ( -- int32 )
4 read byte-array>number ; inline
4 read signed-le> ; inline
: read-longlong ( -- longlong )
8 read byte-array>number ; inline
8 read signed-le> ; inline
: read-double ( -- double )
8 read byte-array>number bits>double ; inline
8 read le> bits>double ; inline
: read-byte-raw ( -- byte-raw )
1 read ; inline

15
extra/bson/writer/writer.factor
View File

@ -75,24 +75,23 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
: write-byte ( byte -- ) CHAR-SIZE >le write ; inline
: write-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-eoo ( -- ) T_EOO write-byte ; inline
: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
: write-eoo ( -- ) T_EOO write1 ; inline
: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
M: string bson-write ( obj -- )
'[ _ write-cstring ] with-length-prefix-excl ;
M: f bson-write ( f -- )
drop 0 write-byte ;
drop 0 write1 ;
M: t bson-write ( t -- )
drop 1 write-byte ;
drop 1 write1 ;
M: integer bson-write ( num -- )
write-int32 ;
@ -105,7 +104,7 @@ M: timestamp bson-write ( timestamp -- )
M: byte-array bson-write ( binary -- )
[ length write-int32 ] keep
T_Binary_Bytes write-byte
T_Binary_Bytes write1
write ;
M: oid bson-write ( oid -- )
@ -134,7 +133,7 @@ M: assoc bson-write ( assoc -- )
: (serialize-code) ( code -- )
object>bytes [ length write-int32 ] keep
T_Binary_Custom write-byte
T_Binary_Custom write1
write ;
M: quotation bson-write ( quotation -- )

1
extra/central/authors.txt Normal file
View File

@ -0,0 +1 @@
Matthew Willis

16
extra/central/central-docs.factor Normal file
View File

@ -0,0 +1,16 @@
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 } "."
} ;

19
extra/central/central-tests.factor Normal file
View File

@ -0,0 +1,19 @@
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

28
extra/central/central.factor Normal file
View File

@ -0,0 +1,28 @@
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 ;

1
extra/central/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

2
extra/contributors/contributors.factor
View File

@ -7,7 +7,7 @@ IN: contributors
: changelog ( -- authors )
image parent-directory [
"git log --pretty=format:%an" ascii <process-reader> stream-lines
"git log --no-merges --pretty=format:%an" ascii <process-reader> stream-lines
] with-directory ;
: patch-counts ( authors -- assoc )

2
extra/html/elements/elements.factor
View File

@ -98,7 +98,7 @@ SYMBOL: html
[
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"b" "i" "ul" "table" "thead" "tfoot" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
"strong"
] [ define-closed-html-word ] each

1
extra/llvm/authors.txt Normal file
View File

@ -0,0 +1 @@
Matthew Willis

418
extra/llvm/core/core.factor Normal file
View File

@ -0,0 +1,418 @@
! 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 ) ;

68
extra/llvm/engine/engine.factor Normal file
View File

@ -0,0 +1,68 @@
! 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 ) ;

7
extra/llvm/invoker/invoker-tests.factor Normal file
View File

@ -0,0 +1,7 @@
! 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

56
extra/llvm/invoker/invoker.factor Normal file
View File

@ -0,0 +1,56 @@
! 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 >>

5
extra/llvm/jit/jit-tests.factor Normal file
View File

@ -0,0 +1,5 @@
! 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

49
extra/llvm/jit/jit.factor Normal file
View File

@ -0,0 +1,49 @@
! 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

BIN
extra/llvm/reader/add.bc Normal file
View File

Binary file not shown.

5
extra/llvm/reader/add.ll Normal file
View File

@ -0,0 +1,5 @@
define i32 @add(i32 %x, i32 %y) {
entry:
%sum = add i32 %x, %y
ret i32 %sum
}

20
extra/llvm/reader/reader.factor Normal file
View File

@ -0,0 +1,20 @@
! 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 ;

1
extra/llvm/tags.txt Normal file
View File

@ -0,0 +1 @@
bindings

40
extra/llvm/types/types-tests.factor Normal file
View File

@ -0,0 +1,40 @@
! 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

246
extra/llvm/types/types.factor Normal file
View File

@ -0,0 +1,246 @@
! 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 ;

7
extra/llvm/wrappers/wrappers-tests.factor Normal file
View File

@ -0,0 +1,7 @@
! 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

62
extra/llvm/wrappers/wrappers.factor Normal file
View File

@ -0,0 +1,62 @@
! 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> ;

2
extra/mongodb/benchmark/benchmark.factor
View File

@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
[ create-collection ] keep ;
: prepare-index ( collection -- )
"_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
"_x_idx" [ "x" asc ] key-spec <index-spec> t >>unique? ensure-index ;
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
prepare-collection

10
extra/mongodb/connection/connection.factor
View File

@ -1,6 +1,6 @@
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
math.parser mongodb.msg mongodb.operations namespaces destructors
constructors sequences splitting checksums checksums.md5 formatting
constructors sequences splitting checksums checksums.md5
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
arrays hashtables sequences.deep vectors locals ;
@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
mdb-connection get instance>> ; inline
: index-collection ( -- ns )
mdb-instance name>> "%s.system.indexes" sprintf ; inline
mdb-instance name>> "system.indexes" "." glue ; inline
: namespaces-collection ( -- ns )
mdb-instance name>> "%s.system.namespaces" sprintf ; inline
mdb-instance name>> "system.namespaces" "." glue ; inline
: cmd-collection ( -- ns )
mdb-instance name>> "%s.$cmd" sprintf ; inline
mdb-instance name>> "$cmd" "." glue ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
[ mdb-instance name>> ] dip "." glue ; inline
: send-message ( message -- )
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;

2
extra/mongodb/driver/driver-docs.factor
View File

@ -131,7 +131,7 @@ HELP: ensure-index
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
{ $unchecked-example "USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
"\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> t >>unique? ensure-index ] with-db" "" } } ;
HELP: explain.
{ $values

79
extra/mongodb/driver/driver.factor
View File

@ -1,8 +1,8 @@
USING: accessors assocs bson.constants bson.writer combinators combinators.smart
constructors continuations destructors formatting fry io io.pools
io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
namespaces parser prettyprint sequences sets splitting strings uuid arrays
math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
USING: accessors arrays assocs bson.constants combinators
combinators.smart constructors destructors formatting fry hashtables
io io.pools io.sockets kernel linked-assocs math mongodb.connection
mongodb.msg parser prettyprint sequences sets splitting strings
tools.continuations uuid memoize locals ;
IN: mongodb.driver
@ -23,9 +23,6 @@ TUPLE: index-spec
CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
: unique-index ( index-spec -- index-spec )
t >>unique? ;
M: mdb-pool make-connection
mdb>> mdb-open ;
@ -83,6 +80,15 @@ M: mdb-getmore-msg verify-query-result
[ make-cursor ] 2tri
swap objects>> ;
: make-collection-assoc ( collection assoc -- )
[ [ name>> "create" ] dip set-at ]
[ [ [ capped>> ] keep ] dip
'[ _ _
[ [ drop t "capped" ] dip set-at ]
[ [ size>> "size" ] dip set-at ]
[ [ max>> "max" ] dip set-at ] 2tri ] when
] 2bi ;
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
@ -100,23 +106,17 @@ SYNTAX: r/ ( token -- mdbregexp )
H{ } clone [ set-at ] keep <mdb-db>
[ verify-nodes ] keep ;
GENERIC: create-collection ( name -- )
GENERIC: create-collection ( name/collection -- )
M: string create-collection
<mdb-collection> create-collection ;
M: mdb-collection create-collection
[ cmd-collection ] dip
<linked-hash> [
[ [ name>> "create" ] dip set-at ]
[ [ [ capped>> ] keep ] dip
'[ _ _
[ [ drop t "capped" ] dip set-at ]
[ [ size>> "size" ] dip set-at ]
[ [ max>> "max" ] dip set-at ] 2tri ] when
] 2bi
] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
[ [ cmd-collection ] dip
<linked-hash> [ make-collection-assoc ] keep
<mdb-query-msg> 1 >>return# send-query-plain drop ] keep
[ ] [ name>> ] bi mdb-instance collections>> set-at ;
: load-collection-list ( -- collection-list )
namespaces-collection
H{ } clone <mdb-query-msg> send-query-plain objects>> ;
@ -125,27 +125,36 @@ M: mdb-collection create-collection
: ensure-valid-collection-name ( collection -- )
[ ";$." intersect length 0 > ] keep
'[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
'[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
: (ensure-collection) ( collection -- )
mdb-instance collections>> dup keys length 0 =
[ load-collection-list
[ [ "options" ] dip key? ] filter
[ [ "name" ] dip at "." split second <mdb-collection> ] map
over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
[ dup ] dip key? [ drop ]
[ [ ensure-valid-collection-name ] keep create-collection ] if ;
: build-collection-map ( -- assoc )
H{ } clone load-collection-list
[ [ "name" ] dip at "." split second <mdb-collection> ] map
over '[ [ ] [ name>> ] bi _ set-at ] each ;
: ensure-collection-map ( mdb-instance -- assoc )
dup collections>> dup keys length 0 =
[ drop build-collection-map [ >>collections drop ] keep ]
[ nip ] if ;
: (ensure-collection) ( collection mdb-instance -- collection )
ensure-collection-map [ dup ] dip key?
[ ] [ [ ensure-valid-collection-name ]
[ create-collection ]
[ ] tri ] if ;
: reserved-namespace? ( name -- ? )
[ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection )
dup mdb-collection? [ name>> ] when
"." split1 over mdb-instance name>> =
[ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi
[ [ (ensure-collection) ] keep ] unless
[ mdb-instance name>> ] dip "%s.%s" sprintf ;
[let* | instance [ mdb-instance ]
instance-name [ instance name>> ] |
dup mdb-collection? [ name>> ] when
"." split1 over instance-name =
[ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi
[ instance (ensure-collection) ] unless
[ instance-name ] dip "." glue ] ;
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline

2
extra/mongodb/tuple/collection/collection.factor
View File

@ -88,7 +88,7 @@ GENERIC: mdb-index-map ( tuple -- sequence )
: user-defined-key-index ( class -- assoc )
mdb-slot-map user-defined-key
[ drop [ "user-defined-key-index" 1 ] dip
H{ } clone [ set-at ] keep <tuple-index> unique-index
H{ } clone [ set-at ] keep <tuple-index> t >>unique?
[ ] [ name>> ] bi H{ } clone [ set-at ] keep
] [ 2drop H{ } clone ] if ;

11
misc/fuel/fuel-syntax.el
View File

@ -54,7 +54,8 @@
"HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"LIBRARY:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
"M:" "M::" "MACRO:" "MACRO::" "MAIN:" "MATH:"
"MEMO:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:"
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"QUALIFIED-WITH:" "QUALIFIED:"
@ -83,7 +84,7 @@
(format "%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst fuel-syntax--method-definition-regex
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
"^M::? +\\([^ ]+\\) +\\([^ ]+\\)")
(defconst fuel-syntax--integer-regex
"\\_<-?[0-9]+\\_>")
@ -154,7 +155,7 @@
"C-ENUM" "C-STRUCT" "C-UNION"
"FROM" "FUNCTION:"
"INTERSECTION:"
"M" "MACRO" "MACRO:"
"M" "M:" "MACRO" "MACRO:"
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
@ -215,7 +216,9 @@
(format ":[^ ]* \\([^ ]+\\)\\(%s\\)*" fuel-syntax--stack-effect-regex))
(defconst fuel-syntax--defun-signature-regex
(format "\\(%s\\|%s\\)" fuel-syntax--word-signature-regex "M[^:]*: [^ ]+ [^ ]+"))
(format "\\(%s\\|%s\\)"
fuel-syntax--word-signature-regex
"M[^:]*: [^ ]+ [^ ]+"))
(defconst fuel-syntax--constructor-decl-regex
"\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")

11
vm/alien.cpp
View File

@ -134,20 +134,21 @@ PRIMITIVE(dlsym)
box_alien(ffi_dlsym(NULL,sym));
else
{
tagged<dll> d = library.as<dll>();
d.untag_check();
dll *d = untag_check<dll>(library.value());
if(d->dll == NULL)
dpush(F);
else
box_alien(ffi_dlsym(d.untagged(),sym));
box_alien(ffi_dlsym(d,sym));
}
}
/* close a native library handle */
PRIMITIVE(dlclose)
{
ffi_dlclose(untag_check<dll>(dpop()));
dll *d = untag_check<dll>(dpop());
if(d->dll != NULL)
ffi_dlclose(d);
}
PRIMITIVE(dll_validp)
@ -156,7 +157,7 @@ PRIMITIVE(dll_validp)
if(library == F)
dpush(T);
else
dpush(tagged<dll>(library)->dll == NULL ? F : T);
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
}
/* gets the address of an object representing a C pointer */