[
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 ;
#! 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 )
: 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 -- )
: 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 -- )
[ 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 ;
[ 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 ;
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*
! 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
\ 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 [
<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
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
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 ;
! 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:
<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
+
! 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
\ 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 ;
\ 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 ;
\ 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 ;
\ 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 ;
"coercer"
"combination"
"compiled-generic-uses"
- "compiled-uses"
+ "effect-dependencies"
+ "definition-dependencies"
"conditional-dependencies"
+ "dependency-checks"
"constant"
"constraints"
"custom-inlining"
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 ;
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 ;
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" } }
[ { } ]
[
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
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 -- )
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 ;
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 ;
--- /dev/null
+! (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) ;
--- /dev/null
+Tool for generating an atlas image from an array of images
projects / factor.git / commitdiff