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

Merge up

db4
erikc 2010-01-30 20:48:06 -08:00
parent f4865e0f9a 5ed0bc72aa
commit 0770b940b0
17 changed files with 237 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/compiler/compiler.factor
View File

@ -86,7 +86,7 @@ M: word combinator? inline? ;
[
dup crossref? [
[ dependencies get generic-dependencies get compiled-xref ]
[ conditional-dependencies get save-conditional-dependencies ]
[ conditional-dependencies get set-dependency-checks ]
bi
] [ drop ] if
] tri ;
@ -184,8 +184,8 @@ M: optimizing-compiler update-call-sites ( class generic -- words )
#! Words containing call sites with inferred type 'class'
#! which inlined a method on 'generic'
compiled-generic-usage swap '[
nip dup forgotten-class?
[ drop f ] [ _ classes-intersect? ] if
nip dup classoid?
[ _ classes-intersect? ] [ drop f ] if
] assoc-filter keys ;
M: optimizing-compiler recompile ( words -- alist )

10
basis/compiler/crossref/crossref.factor
View File

@ -55,7 +55,7 @@ compiled-generic-crossref [ H{ } clone ] initialize
: store-dependencies ( word assoc -- )
split-dependencies
"effect-dependencies" "definition-dependencies" "conditional-dependencies"
"effect-dependencies" "conditional-dependencies" "definition-dependencies"
[ (store-dependencies) ] tri-curry@ tri-curry* tri ;
: (compiled-xref) ( word dependencies generic-dependencies -- )
@ -81,8 +81,8 @@ compiled-generic-crossref [ H{ } clone ] initialize
: load-dependencies ( word -- assoc )
[ "effect-dependencies" word-prop ]
[ "definition-dependencies" word-prop ]
[ "conditional-dependencies" word-prop ] tri
[ "conditional-dependencies" word-prop ]
[ "definition-dependencies" word-prop ] tri
join-dependencies ;
: (compiled-unxref) ( word dependencies variable -- )
@ -96,8 +96,8 @@ compiled-generic-crossref [ H{ } clone ] initialize
[ dup load-dependencies compiled-crossref (compiled-unxref) ]
[ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ]
[ "effect-dependencies" remove-word-prop ]
[ "definition-dependencies" remove-word-prop ]
[ "conditional-dependencies" remove-word-prop ]
[ "definition-dependencies" remove-word-prop ]
[ "compiled-generic-uses" remove-word-prop ]
} cleave ;
@ -107,5 +107,5 @@ compiled-generic-crossref [ H{ } clone ] initialize
[ compiled-generic-crossref get delete-at ]
tri ;
: save-conditional-dependencies ( word deps -- )
: set-dependency-checks ( word deps -- )
keys f like "dependency-checks" set-word-prop ;

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

@ -8,7 +8,7 @@ layouts compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker slots.private words
hashtables classes assocs locals specialized-arrays system
sorting math.libm math.floats.private math.integers.private
math.intervals quotations effects alien alien.data ;
math.intervals quotations effects alien alien.data sets ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void*
@ -952,3 +952,13 @@ M: tuple-with-read-only-slot clone
! Reduction
[ 1 ] [ [ 4 <reversed> [ nth-unsafe ] [ ] unless ] final-info length ] unit-test
! Optimization on bit?
[ t ] [ [ 3 bit? ] { bit? fixnum-bit? } inlined? ] unit-test
[ f ] [ [ 500 bit? ] { bit? fixnum-bit? } inlined? ] unit-test
[ t ] [ [ { 1 } intersect ] { intersect } inlined? ] unit-test
[ f ] [ [ { 1 } swap intersect ] { intersect } inlined? ] unit-test ! We could do this
[ t ] [ [ { 1 } diff ] { diff } inlined? ] unit-test
[ f ] [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this

9
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -284,6 +284,15 @@ CONSTANT: lookup-table-at-max 256
\ intersect [ intersect-quot ] 1 define-partial-eval
: fixnum-bits ( -- n )
cell-bits tag-bits get - ;
: bit-quot ( #call -- quot/f )
in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
[ [ >fixnum ] dip fixnum-bit? ] f ? ;
\ bit? [ bit-quot ] "custom-inlining" set-word-prop
! Speeds up sum-file, sort and reverse-complement benchmarks by
! compiling decoder-readln better
\ push [

57
basis/grouping/grouping.factor
View File

@ -6,35 +6,29 @@ IN: grouping
<PRIVATE
TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups ( n -- n )
dup 0 <= [ "Invalid group count" throw ] when ; inline
: new-groups ( seq n class -- groups )
[ check-groups ] dip boa ; inline
MIXIN: chunking
INSTANCE: chunking sequence
GENERIC: group@ ( n groups -- from to seq )
M: chunking-seq set-nth group@ <slice> 0 swap copy ;
M: chunking-seq like drop { } like ; inline
M: chunking set-nth group@ <slice> 0 swap copy ;
M: chunking like drop { } like ; inline
MIXIN: subseq-chunking
INSTANCE: subseq-chunking chunking
INSTANCE: subseq-chunking sequence
M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
INSTANCE: slice-chunking chunking
INSTANCE: slice-chunking sequence
M: slice-chunking nth group@ <slice> ; inline
M: slice-chunking nth-unsafe group@ slice boa ; inline
TUPLE: abstract-groups < chunking-seq ;
MIXIN: abstract-groups
INSTANCE: abstract-groups sequence
M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
@ -45,7 +39,8 @@ M: abstract-groups set-length
M: abstract-groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
TUPLE: abstract-clumps < chunking-seq ;
MIXIN: abstract-clumps
INSTANCE: abstract-clumps sequence
M: abstract-clumps length
[ seq>> length 1 + ] [ n>> ] bi [-] ; inline
@ -56,36 +51,44 @@ M: abstract-clumps set-length
M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ; inline
TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups ( n -- n )
dup 0 <= [ "Invalid group count" throw ] when ; inline
: new-groups ( seq n class -- groups )
[ check-groups ] dip boa ; inline
PRIVATE>
TUPLE: groups < abstract-groups ;
TUPLE: groups < chunking-seq ;
INSTANCE: groups subseq-chunking
INSTANCE: groups abstract-groups
: <groups> ( seq n -- groups )
groups new-groups ; inline
INSTANCE: groups subseq-chunking
TUPLE: sliced-groups < abstract-groups ;
TUPLE: sliced-groups < chunking-seq ;
INSTANCE: sliced-groups slice-chunking
INSTANCE: sliced-groups abstract-groups
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
INSTANCE: sliced-groups slice-chunking
TUPLE: clumps < abstract-clumps ;
TUPLE: clumps < chunking-seq ;
INSTANCE: clumps subseq-chunking
INSTANCE: clumps abstract-clumps
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
INSTANCE: clumps subseq-chunking
TUPLE: sliced-clumps < abstract-clumps ;
TUPLE: sliced-clumps < chunking-seq ;
INSTANCE: sliced-clumps slice-chunking
INSTANCE: sliced-clumps abstract-clumps
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
INSTANCE: sliced-clumps slice-chunking
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;

27
basis/images/images.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel accessors sequences math arrays ;
USING: combinators kernel locals accessors sequences math arrays ;
IN: images
SINGLETONS:
@ -128,18 +128,31 @@ TUPLE: image dim component-order component-type upside-down? bitmap ;
<PRIVATE
: pixel@ ( x y image -- start end bitmap )
[ dim>> first * + ]
[ bytes-per-pixel [ * dup ] keep + ]
[ bitmap>> ] tri ;
:: pixel@ ( x y w image -- start end bitmap )
image dim>> first y * x + :> start
start w [ image bytes-per-pixel * ] bi@ :> ( start' w' )
start' start' w' + image bitmap>> ; inline
: set-subseq ( new-value from to victim -- )
<slice> 0 swap copy ; inline
PRIVATE>
: pixel-row-at ( x y w image -- pixels )
pixel@ subseq ; inline
: pixel-row-slice-at ( x y w image -- pixels )
pixel@ <slice> ; inline
: set-pixel-row-at ( pixel x y w image -- )
pixel@ set-subseq ; inline
: pixel-at ( x y image -- pixel )
pixel@ subseq ;
[ 1 ] dip pixel-row-at ; inline
: pixel-slice-at ( x y image -- pixels )
[ 1 ] dip pixel-row-slice-at ; inline
: set-pixel-at ( pixel x y image -- )
pixel@ set-subseq ;
[ 1 ] dip set-pixel-row-at ; inline

24
basis/stack-checker/dependencies/dependencies.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors classes.algebra fry generic kernel math
namespaces sequences words sets ;
namespaces sequences words sets combinators.short-circuit ;
FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
@ -62,7 +62,11 @@ TUPLE: depends-on-class<= class1 class2 ;
\ depends-on-class<= add-conditional-dependency ;
M: depends-on-class<= satisfied?
[ class1>> ] [ class2>> ] bi class<= ;
{
[ class1>> classoid? ]
[ class2>> classoid? ]
[ [ class1>> ] [ class2>> ] bi class<= ]
} 1&& ;
TUPLE: depends-on-classes-disjoint class1 class2 ;
@ -70,7 +74,11 @@ TUPLE: depends-on-classes-disjoint class1 class2 ;
\ depends-on-classes-disjoint add-conditional-dependency ;
M: depends-on-classes-disjoint satisfied?
[ class1>> ] [ class2>> ] bi classes-intersect? not ;
{
[ class1>> classoid? ]
[ class2>> classoid? ]
[ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
} 1&& ;
TUPLE: depends-on-next-method class generic next-method ;
@ -79,7 +87,10 @@ TUPLE: depends-on-next-method class generic next-method ;
\ depends-on-next-method add-conditional-dependency ;
M: depends-on-next-method satisfied?
[ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ;
{
[ class>> classoid? ]
[ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-method class generic method ;
@ -88,7 +99,10 @@ TUPLE: depends-on-method class generic method ;
\ depends-on-method add-conditional-dependency ;
M: depends-on-method satisfied?
[ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ;
{
[ class>> classoid? ]
[ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-tuple-layout class layout ;

4
basis/tools/deploy/shaker/shaker.factor
View File

@ -127,8 +127,10 @@ IN: tools.deploy.shaker
"coercer"
"combination"
"compiled-generic-uses"
"compiled-uses"
"effect-dependencies"
"definition-dependencies"
"conditional-dependencies"
"dependency-checks"
"constant"
"constraints"
"custom-inlining"

10
core/classes/algebra/algebra.factor
View File

@ -40,12 +40,12 @@ M: object normalize-class ;
PRIVATE>
GENERIC: forgotten-class? ( obj -- ? )
GENERIC: classoid? ( obj -- ? )
M: word forgotten-class? "forgotten" word-prop ;
M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ;
M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ;
M: anonymous-complement forgotten-class? class>> forgotten-class? ;
M: word classoid? class? ;
M: anonymous-union classoid? members>> [ classoid? ] all? ;
M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
M: anonymous-complement classoid? class>> classoid? ;
: class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ;

5
core/math/integers/integers.factor
View File

@ -58,7 +58,10 @@ M: fixnum shift >fixnum fixnum-shift ; inline
M: fixnum bitnot fixnum-bitnot ; inline
M: fixnum bit? neg shift 1 bitand 0 > ; inline
: fixnum-bit? ( n m -- b )
neg shift 1 bitand 0 > ; inline
M: fixnum bit? fixnum-bit? ; inline
: fixnum-log2 ( x -- n )
0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;

2
core/math/math-docs.factor
View File

@ -403,7 +403,7 @@ HELP: number
HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 2." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }

6
core/words/words-tests.factor
View File

@ -122,8 +122,10 @@ DEFER: x
[ { } ]
[
all-words [
"compiled-uses" word-prop 2 <groups>
keys [ "forgotten" word-prop ] filter
[ "effect-dependencies" word-prop ]
[ "definition-dependencies" word-prop ]
[ "conditional-dependencies" word-prop ] tri
3append [ "forgotten" word-prop ] filter
] map harvest
] unit-test

15
extra/benchmark/nsieve-bits/nsieve-bits.factor
View File

@ -1,5 +1,5 @@
USING: math math.parser sequences sequences.private kernel
bit-arrays make io ;
bit-arrays make io math.ranges multiline fry locals ;
IN: benchmark.nsieve-bits
: clear-flags ( step i seq -- )
@ -13,23 +13,24 @@ IN: benchmark.nsieve-bits
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
rot 1 + -rot ! increment count
[ 1 + ] 2dip ! increment count
] when [ 1 + ] dip (nsieve-bits)
] [
2drop
] if ; inline recursive
: nsieve-bits ( m -- count )
0 2 rot 1 + <bit-array> dup set-bits (nsieve-bits) ;
[ 0 2 ] dip 1 + <bit-array> dup set-bits (nsieve-bits) ;
: nsieve-bits. ( m -- )
[ "Primes up to " % dup # " " % nsieve-bits # ] "" make
print ;
print ; inline
: nsieve-bits-main ( n -- )
dup 2^ 10000 * nsieve-bits.
dup 1 - 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
[ 2^ 10000 * nsieve-bits. ]
[ 1 - 2^ 10000 * nsieve-bits. ]
[ 2 - 2^ 10000 * nsieve-bits. ]
tri ;
: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;

11
extra/benchmark/nsieve/nsieve.factor
View File

@ -13,22 +13,23 @@ IN: benchmark.nsieve
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
rot 1 + -rot ! increment count
[ 1 + ] 2dip ! increment count
] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
0 2 rot 1 + t <array> (nsieve) ;
[ 0 2 ] dip 1 + t <array> (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
: nsieve-main ( n -- )
dup 2^ 10000 * nsieve.
dup 1 - 2^ 10000 * nsieve.
2 - 2^ 10000 * nsieve. ;
[ 2^ 10000 * nsieve. ]
[ 1 - 2^ 10000 * nsieve. ]
[ 2 - 2^ 10000 * nsieve. ]
tri ;
: nsieve-main* ( -- ) 9 nsieve-main ;

107
extra/images/atlas/atlas.factor Normal file
View File

@ -0,0 +1,107 @@
! (c)2010 Joe Groff bsd license
USING: accessors byte-arrays fry images kernel locals math
math.functions math.order math.vectors namespaces sequences
sorting ;
IN: images.atlas
! sort rects by height/width/whatever
! use least power of two greater than k * greatest width for atlas width
! pack stripes(y 0):
! place first rect at x 0
! place rects that fit in remaining stripe
! pack stripes(y + height)
! if height > max height
TUPLE: image-placement
{ image read-only }
loc ;
CONSTANT: atlas-waste-factor 1.25
CONSTANT: atlas-padding 1
ERROR: atlas-image-formats-dont-match images ;
<PRIVATE
: width ( dim -- width ) first atlas-padding + ; inline
: height ( dim -- height ) second atlas-padding + ; inline
: area ( dim -- area ) [ width ] [ height ] bi * ; inline
:: (pack-stripe) ( image-placements atlas-width @y -- stripe-height/f )
0 :> @x!
f :> stripe-height!
image-placements [| ip |
ip loc>> [
ip image>> dim>> :> dim
stripe-height [ dim height stripe-height 0 or max stripe-height! ] unless
dim width :> w
atlas-width w @x + >= [
ip { @x @y } >>loc drop
@x w + @x!
] when
] unless
] each
stripe-height ;
:: (pack-images) ( images atlas-width sort-quot -- placements )
images sort-quot inv-sort-with [ f image-placement boa ] map :> image-placements
0 :> @y!
[ image-placements atlas-width @y (pack-stripe) dup ] [ @y + @y! ] while drop
image-placements ; inline
: atlas-image-format ( image-placements -- component-order component-type upside-down? )
[ image>> ] map dup unclip '[ _
[ [ component-order>> ] bi@ = ]
[ [ component-type>> ] bi@ = ]
[ [ upside-down?>> ] bi@ = ] 2tri and and
] all?
[ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
[ atlas-image-formats-dont-match ] if ; inline
: atlas-dim ( image-placements -- dim )
[ [ loc>> ] [ image>> dim>> ] bi v+ atlas-padding v+n ] [ vmax ] map-reduce
[ next-power-of-2 ] map ; inline
:: <atlas-image> ( image-placements component-order component-type upside-down? -- atlas )
image-placements atlas-dim :> dim
<image>
dim >>dim
component-order >>component-order
component-type >>component-type
upside-down? >>upside-down?
dim product component-order component-type (bytes-per-pixel) * <byte-array> >>bitmap ; inline
:: copy-image-into-atlas ( image-placement atlas -- )
image-placement image>> :> image
image dim>> first2 :> ( w h )
image-placement loc>> first2 :> ( x y )
h iota [| row |
0 row w image pixel-row-slice-at
x y row + w atlas set-pixel-row-at
] each ; inline
: copy-images-into-atlas ( image-placements atlas -- )
'[ _ copy-image-into-atlas ] each ; inline
PRIVATE>
: (guess-atlas-dim) ( images -- width )
[ dim>> area ] [ + ] map-reduce sqrt
atlas-waste-factor *
.5 + >integer ;
: guess-atlas-dim ( images -- width )
[ (guess-atlas-dim) ] [ [ dim>> width ] [ max ] map-reduce ] bi max next-power-of-2 ;
: pack-images ( images atlas-width -- placements )
[ dim>> second ] (pack-images) ;
: pack-atlas ( images -- image-placements )
dup guess-atlas-dim pack-images ;
: (make-atlas) ( image-placements -- image )
dup dup atlas-image-format <atlas-image> [ copy-images-into-atlas ] keep ;
: make-atlas ( images -- image-placements atlas-image )
pack-atlas dup (make-atlas) ;

1
extra/images/atlas/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

1
extra/images/atlas/summary.txt Normal file
View File

@ -0,0 +1 @@
Tool for generating an atlas image from an array of images