Merge branch 'master' into inline_caching
Slava Pestov
commit
bf0e8606a8
4
Makefile
4
Makefile
|
|
@ -15,9 +15,11 @@ FFI_TEST_CFLAGS = -fPIC
|
|||
ifdef DEBUG
|
||||
CFLAGS += -g
|
||||
else
|
||||
CFLAGS += -O3 $(SITE_CFLAGS)
|
||||
CFLAGS += -O3
|
||||
endif
|
||||
|
||||
CFLAGS += $(SITE_CFLAGS)
|
||||
|
||||
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
||||
|
||||
ifdef CONFIG
|
||||
|
|
|
|||
|
|
@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
|
|||
[ infer in>> ] keep
|
||||
'[ _ firstn @ ] ;
|
||||
|
||||
MACRO: input<sequence-unsafe ( quot -- newquot )
|
||||
[ infer in>> ] keep
|
||||
'[ _ firstn-unsafe @ ] ;
|
||||
|
||||
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||
[ dup infer out>> 1 [-] ] dip n*quot compose ;
|
||||
|
||||
|
|
|
|||
|
|
@ -54,15 +54,16 @@ PRIVATE>
|
|||
#! This slows down compiler.tree.propagation.inlining since then every
|
||||
#! inlined usage of a method has an inline-dependency on the mixin, and
|
||||
#! not the more specific type at the call site.
|
||||
specialize-method? off
|
||||
[
|
||||
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
|
||||
{
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
|
||||
[ in-d #call out-d>> #copy suffix ]
|
||||
} cond
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
|
||||
f specialize-method? [
|
||||
[
|
||||
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
|
||||
{
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
|
||||
[ in-d #call out-d>> #copy suffix ]
|
||||
} cond
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
|
||||
] with-variable ;
|
||||
|
||||
: contains-breakpoints? ( word -- ? )
|
||||
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
||||
|
|
|
|||
|
|
@ -18,6 +18,8 @@ IN: functors
|
|||
|
||||
: define-declared* ( word def effect -- ) pick set-word define-declared ;
|
||||
|
||||
TUPLE: fake-call-next-method ;
|
||||
|
||||
TUPLE: fake-quotation seq ;
|
||||
|
||||
GENERIC: >fake-quotations ( quot -- fake )
|
||||
|
|
@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
|
|||
|
||||
M: object >fake-quotations ;
|
||||
|
||||
GENERIC: fake-quotations> ( fake -- quot )
|
||||
GENERIC: (fake-quotations>) ( fake -- )
|
||||
|
||||
M: fake-quotation fake-quotations>
|
||||
seq>> [ fake-quotations> ] [ ] map-as ;
|
||||
: fake-quotations> ( fake -- quot )
|
||||
[ (fake-quotations>) ] [ ] make ;
|
||||
|
||||
M: array fake-quotations> [ fake-quotations> ] map ;
|
||||
M: fake-quotation (fake-quotations>)
|
||||
[ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
|
||||
|
||||
M: object fake-quotations> ;
|
||||
M: array (fake-quotations>)
|
||||
[ [ (fake-quotations>) ] each ] { } make , ;
|
||||
|
||||
M: fake-call-next-method (fake-quotations>)
|
||||
drop method-body get literalize , \ (call-next-method) , ;
|
||||
|
||||
M: object (fake-quotations>) , ;
|
||||
|
||||
: parse-definition* ( accum -- accum )
|
||||
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
|
||||
parse-definition >fake-quotations parsed
|
||||
[ fake-quotations> first ] over push-all ;
|
||||
|
||||
: parse-declared* ( accum -- accum )
|
||||
complete-effect
|
||||
|
|
@ -64,7 +74,7 @@ SYNTAX: `TUPLE:
|
|||
SYNTAX: `M:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ create-method-in parsed
|
||||
[ create-method-in dup method-body set ] over push-all
|
||||
parse-definition*
|
||||
\ define* parsed ;
|
||||
|
||||
|
|
@ -92,6 +102,8 @@ SYNTAX: `INSTANCE:
|
|||
|
||||
SYNTAX: `inline [ word make-inline ] over push-all ;
|
||||
|
||||
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
|
||||
|
||||
: (INTERPOLATE) ( accum quot -- accum )
|
||||
[ scan interpolate-locals ] dip
|
||||
'[ _ with-string-writer @ ] parsed ;
|
||||
|
|
@ -117,6 +129,7 @@ DEFER: ;FUNCTOR delimiter
|
|||
{ "INSTANCE:" POSTPONE: `INSTANCE: }
|
||||
{ "SYNTAX:" POSTPONE: `SYNTAX: }
|
||||
{ "inline" POSTPONE: `inline }
|
||||
{ "call-next-method" POSTPONE: `call-next-method }
|
||||
} ;
|
||||
|
||||
: push-functor-words ( -- )
|
||||
|
|
|
|||
|
|
@ -26,11 +26,14 @@ MACRO: narray ( n -- )
|
|||
MACRO: nsum ( n -- )
|
||||
1- [ + ] n*quot ;
|
||||
|
||||
MACRO: firstn-unsafe ( n -- )
|
||||
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
|
||||
[ 1- '[ [ _ ] dip bounds-check 2drop ] ]
|
||||
bi prefix '[ _ cleave ]
|
||||
[ 1- swap bounds-check 2drop ]
|
||||
[ firstn-unsafe ]
|
||||
bi-curry '[ _ _ bi ]
|
||||
] if ;
|
||||
|
||||
MACRO: npick ( n -- )
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: inverse
|
|||
ERROR: fail ;
|
||||
M: fail summary drop "Matching failed" ;
|
||||
|
||||
: assure ( ? -- ) [ fail ] unless ;
|
||||
: assure ( ? -- ) [ fail ] unless ; inline
|
||||
|
||||
: =/fail ( obj1 obj2 -- ) = assure ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
||||
|
|
@ -1 +0,0 @@
|
|||
Packed homogeneous tuple arrays
|
||||
|
|
@ -1 +0,0 @@
|
|||
collections
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
USING: help.syntax help.markup splitting kernel sequences ;
|
||||
IN: tuple-arrays
|
||||
|
||||
HELP: tuple-array
|
||||
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
|
||||
|
||||
HELP: <tuple-array>
|
||||
{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
|
||||
{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
|
||||
|
||||
HELP: >tuple-array
|
||||
{ $values { "seq" sequence } { "tuple-array" tuple-array } }
|
||||
{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;
|
||||
|
|
@ -5,17 +5,28 @@ IN: tuple-arrays.tests
|
|||
SYMBOL: mat
|
||||
TUPLE: foo bar ;
|
||||
C: <foo> foo
|
||||
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
|
||||
TUPLE-ARRAY: foo
|
||||
|
||||
[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
|
||||
[ T{ foo } ] [ mat get first ] unit-test
|
||||
[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
|
||||
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test
|
||||
[ T{ foo f 3 } t ]
|
||||
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
|
||||
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep foo-array? ] unit-test
|
||||
|
||||
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
|
||||
[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
|
||||
[ T{ foo } ] [ mat get first ] unit-test
|
||||
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
|
||||
TUPLE: baz { bing integer } bong ;
|
||||
[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
|
||||
[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
|
||||
TUPLE-ARRAY: baz
|
||||
|
||||
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
|
||||
[ f ] [ 1 <baz-array> first bong>> ] unit-test
|
||||
|
||||
TUPLE: broken x ;
|
||||
: broken ( -- ) ;
|
||||
|
||||
TUPLE-ARRAY: broken
|
||||
|
||||
[ 100 ] [ 100 <broken-array> length ] unit-test
|
||||
|
|
@ -1,34 +1,73 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg.
|
||||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: splitting grouping classes.tuple classes math kernel
|
||||
sequences arrays accessors ;
|
||||
USING: accessors arrays combinators.smart fry functors kernel
|
||||
kernel.private macros sequences combinators sequences.private
|
||||
stack-checker parser math classes.tuple.private ;
|
||||
FROM: inverse => undo ;
|
||||
IN: tuple-arrays
|
||||
|
||||
TUPLE: tuple-array { seq read-only } { class read-only } ;
|
||||
<PRIVATE
|
||||
|
||||
: <tuple-array> ( length class -- tuple-array )
|
||||
[
|
||||
new tuple>array 1 tail
|
||||
[ <repetition> concat ] [ length ] bi <sliced-groups>
|
||||
] [ ] bi tuple-array boa ;
|
||||
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
|
||||
|
||||
M: tuple-array nth
|
||||
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
|
||||
MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
|
||||
|
||||
M: tuple-array set-nth ( elt n seq -- )
|
||||
[ tuple>array 1 tail ] 2dip seq>> set-nth ;
|
||||
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
|
||||
|
||||
M: tuple-array new-sequence
|
||||
class>> <tuple-array> ;
|
||||
: smart-tuple>array ( tuple class -- array )
|
||||
'[ [ _ boa ] undo ] output>array ; inline
|
||||
|
||||
: >tuple-array ( seq -- tuple-array )
|
||||
dup empty? [
|
||||
0 over first class <tuple-array> clone-like
|
||||
] unless ;
|
||||
: tuple-prototype ( class -- array )
|
||||
[ new ] [ smart-tuple>array ] bi ; inline
|
||||
|
||||
M: tuple-array like
|
||||
drop dup tuple-array? [ >tuple-array ] unless ;
|
||||
: tuple-slice ( n seq -- slice )
|
||||
[ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
|
||||
|
||||
M: tuple-array length seq>> length ;
|
||||
: read-tuple ( slice class -- tuple )
|
||||
'[ _ boa-unsafe ] input<sequence-unsafe ; inline
|
||||
|
||||
INSTANCE: tuple-array sequence
|
||||
MACRO: write-tuple ( class -- quot )
|
||||
[ '[ [ _ boa ] undo ] ]
|
||||
[ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
|
||||
bi '[ _ dip @ ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
FUNCTOR: define-tuple-array ( CLASS -- )
|
||||
|
||||
CLASS IS ${CLASS}
|
||||
|
||||
CLASS-array DEFINES-CLASS ${CLASS}-array
|
||||
CLASS-array? IS ${CLASS-array}?
|
||||
|
||||
<CLASS-array> DEFINES <${CLASS}-array>
|
||||
>CLASS-array DEFINES >${CLASS}-array
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: CLASS-array
|
||||
{ seq array read-only }
|
||||
{ n array-capacity read-only }
|
||||
{ length array-capacity read-only } ;
|
||||
|
||||
: <CLASS-array> ( length -- tuple-array )
|
||||
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
|
||||
\ CLASS-array boa ; inline
|
||||
|
||||
M: CLASS-array length length>> ;
|
||||
|
||||
M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
|
||||
|
||||
M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
|
||||
|
||||
M: CLASS-array new-sequence drop <CLASS-array> ;
|
||||
|
||||
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
|
||||
|
||||
M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
|
||||
|
||||
INSTANCE: CLASS-array sequence
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions tuple-arrays accessors fry sequences
|
||||
prettyprint ;
|
||||
IN: benchmark.tuple-arrays
|
||||
|
||||
TUPLE: point { x float } { y float } { z float } ;
|
||||
|
||||
TUPLE-ARRAY: point
|
||||
|
||||
: tuple-array-benchmark ( -- )
|
||||
100 [
|
||||
drop 5000 <point-array> [
|
||||
[ 1+ ] change-x
|
||||
[ 1- ] change-y
|
||||
[ 1+ 2 / ] change-z
|
||||
] map [ z>> ] sigma
|
||||
] sigma . ;
|
||||
|
||||
MAIN: tuple-array-benchmark
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors pair-methods classes kernel sequences tools.test ;
|
||||
IN: pair-methods.tests
|
||||
|
||||
TUPLE: thang ;
|
||||
|
||||
TUPLE: foom < thang ;
|
||||
TUPLE: barm < foom ;
|
||||
|
||||
TUPLE: zim < thang ;
|
||||
TUPLE: zang < zim ;
|
||||
|
||||
: class-names ( a b prefix -- string )
|
||||
[ [ class name>> ] bi@ "-" glue ] dip prepend ;
|
||||
|
||||
PAIR-GENERIC: blibble ( a b -- c )
|
||||
|
||||
PAIR-M: thang thang blibble
|
||||
"vanilla " class-names ;
|
||||
|
||||
PAIR-M: foom thang blibble
|
||||
"chocolate " class-names ;
|
||||
|
||||
PAIR-M: barm thang blibble
|
||||
"strawberry " class-names ;
|
||||
|
||||
PAIR-M: barm zim blibble
|
||||
"coconut " class-names ;
|
||||
|
||||
[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test
|
||||
|
||||
! args automatically swap to match most specific method
|
||||
[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test
|
||||
[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test
|
||||
|
||||
[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test
|
||||
[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test
|
||||
[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test
|
||||
|
||||
[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test
|
||||
[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test
|
||||
|
||||
[ 1 2 blibble ] [ no-pair-method? ] must-fail-with
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: arrays assocs classes classes.tuple.private combinators
|
||||
effects.parser generic.parser kernel math math.order parser
|
||||
quotations sequences sorting words ;
|
||||
IN: pair-methods
|
||||
|
||||
ERROR: no-pair-method a b generic ;
|
||||
|
||||
: ?swap ( a b ? -- a/b b/a )
|
||||
[ swap ] when ;
|
||||
|
||||
: method-sort-key ( pair -- key )
|
||||
first2 [ tuple-layout third ] bi@ + ;
|
||||
|
||||
: pair-match-condition ( pair -- quot )
|
||||
first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
|
||||
[ 2dup ] [ bi* and ] surround ;
|
||||
|
||||
: pair-method-cond ( pair quot -- array )
|
||||
[ pair-match-condition ] [ ] bi* 2array ;
|
||||
|
||||
: sorted-pair-methods ( word -- alist )
|
||||
"pair-generic-methods" word-prop >alist
|
||||
[ [ first method-sort-key ] bi@ >=< ] sort ;
|
||||
|
||||
: pair-generic-definition ( word -- def )
|
||||
[ sorted-pair-methods [ first2 pair-method-cond ] map ]
|
||||
[ [ no-pair-method ] curry suffix ] bi 1quotation
|
||||
[ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ;
|
||||
|
||||
: make-pair-generic ( word -- )
|
||||
dup pair-generic-definition define ;
|
||||
|
||||
: define-pair-generic ( word effect -- )
|
||||
[ swap set-stack-effect ]
|
||||
[ drop H{ } clone "pair-generic-methods" set-word-prop ]
|
||||
[ drop make-pair-generic ] 2tri ;
|
||||
|
||||
: (PAIR-GENERIC:) ( -- )
|
||||
CREATE-GENERIC complete-effect define-pair-generic ;
|
||||
|
||||
SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
|
||||
|
||||
: define-pair-method ( a b pair-generic definition -- )
|
||||
[ 2array ] 2dip swap
|
||||
[ "pair-generic-methods" word-prop [ swap ] dip set-at ]
|
||||
[ make-pair-generic ] bi ;
|
||||
|
||||
: ?prefix-swap ( quot ? -- quot' )
|
||||
[ \ swap prefix ] when ;
|
||||
|
||||
: (PAIR-M:) ( -- )
|
||||
scan-word scan-word 2dup <=> +gt+ eq? [
|
||||
?swap scan-word parse-definition
|
||||
] keep ?prefix-swap define-pair-method ;
|
||||
|
||||
SYNTAX: PAIR-M: (PAIR-M:) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Order-insensitive double dispatch generics
|
||||
|
|
@ -8,8 +8,8 @@ IN: roles
|
|||
ERROR: role-slot-overlap class slots ;
|
||||
ERROR: multiple-inheritance-attempted classes ;
|
||||
|
||||
PREDICATE: role < class
|
||||
{ [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
|
||||
PREDICATE: role < mixin-class
|
||||
"role-slots" word-prop >boolean ;
|
||||
|
||||
: parse-role-definition ( -- class superroles slots )
|
||||
CREATE-CLASS scan {
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: help.markup help.syntax multiline quotations sequences sequences.product ;
|
||||
IN: sequences
|
||||
|
||||
HELP: product-sequence
|
||||
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
|
||||
{ $examples
|
||||
{ $example <" USING: arrays prettyprint sequences.product ;
|
||||
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
|
||||
"> <" {
|
||||
{ 1 "a" }
|
||||
{ 2 "a" }
|
||||
{ 3 "a" }
|
||||
{ 1 "b" }
|
||||
{ 2 "b" }
|
||||
{ 3 "b" }
|
||||
{ 1 "c" }
|
||||
{ 2 "c" }
|
||||
{ 3 "c" }
|
||||
}"> } } ;
|
||||
|
||||
HELP: <product-sequence>
|
||||
{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
|
||||
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
|
||||
{ $examples
|
||||
{ $example <" USING: arrays prettyprint sequences.product ;
|
||||
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
|
||||
"> <" {
|
||||
{ 1 "a" }
|
||||
{ 2 "a" }
|
||||
{ 3 "a" }
|
||||
{ 1 "b" }
|
||||
{ 2 "b" }
|
||||
{ 3 "b" }
|
||||
{ 1 "c" }
|
||||
{ 2 "c" }
|
||||
{ 3 "c" }
|
||||
}"> } } ;
|
||||
|
||||
{ product-sequence <product-sequence> } related-words
|
||||
|
||||
HELP: product-map
|
||||
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
|
||||
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
|
||||
{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
|
||||
|
||||
HELP: product-each
|
||||
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
|
||||
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
|
||||
{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
|
||||
|
||||
{ product-map product-each } related-words
|
||||
|
||||
ARTICLE: "sequences.product" "Product sequences"
|
||||
"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
|
||||
{ $subsection product-sequence }
|
||||
{ $subsection <product-sequence> }
|
||||
{ $subsection product-map }
|
||||
{ $subsection product-each } ;
|
||||
|
||||
ABOUT: "sequences.product"
|
||||
|
|
@ -1,19 +1,26 @@
|
|||
USING: arrays kernel sequences sequences.cartesian-product tools.test ;
|
||||
! (c)2009 Joe Groff bsd license
|
||||
USING: arrays kernel make sequences sequences.product tools.test ;
|
||||
IN: sequences.product.tests
|
||||
|
||||
[
|
||||
{ { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
|
||||
] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
|
||||
|
||||
[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
|
||||
[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
|
||||
|
||||
: x ( n s -- sss ) <repetition> concat ;
|
||||
|
||||
[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
|
||||
[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
|
||||
{ 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
|
||||
}
|
||||
] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
|
||||
|
||||
[
|
||||
{ "012012" "aaabbb" }
|
||||
] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
|
||||
|
||||
] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
|
||||
|
||||
[ "a1b1c1a2b2c2" ] [
|
||||
[
|
||||
{ { "a" "b" "c" } { "1" "2" } }
|
||||
[ [ % ] each ] product-each
|
||||
] "" make
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays kernel locals math sequences ;
|
||||
IN: sequences.product
|
||||
|
||||
TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
|
||||
|
||||
: <product-sequence> ( sequences -- product-sequence )
|
||||
>array dup [ length ] map product-sequence boa ;
|
||||
|
||||
INSTANCE: product-sequence sequence
|
||||
|
||||
M: product-sequence length lengths>> product ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ns ( n lengths -- ns )
|
||||
[ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
|
||||
|
||||
: nths ( ns seqs -- nths )
|
||||
[ nth ] { } 2map-as ;
|
||||
|
||||
: product@ ( n product-sequence -- ns seqs )
|
||||
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
|
||||
|
||||
:: (carry-n) ( ns lengths i -- )
|
||||
ns length i 1+ = [
|
||||
i ns nth i lengths nth = [
|
||||
0 i ns set-nth
|
||||
i 1+ ns [ 1+ ] change-nth
|
||||
ns lengths i 1+ (carry-n)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: carry-ns ( ns lengths -- )
|
||||
0 (carry-n) ;
|
||||
|
||||
: product-iter ( ns lengths -- )
|
||||
[ 0 over [ 1+ ] change-nth ] dip carry-ns ;
|
||||
|
||||
: start-product-iter ( sequence-product -- ns lengths )
|
||||
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
|
||||
|
||||
: end-product-iter? ( ns lengths -- ? )
|
||||
[ 1 tail* first ] bi@ = ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: product-sequence nth
|
||||
product@ nths ;
|
||||
|
||||
:: product-each ( sequences quot -- )
|
||||
sequences start-product-iter :> lengths :> ns
|
||||
[ ns lengths end-product-iter? ]
|
||||
[ ns sequences nths quot call ns lengths product-iter ] until ; inline
|
||||
|
||||
:: product-map ( sequences quot -- sequence )
|
||||
0 :> i!
|
||||
sequences [ length ] [ * ] map-reduce sequences
|
||||
[| result |
|
||||
sequences [ quot call i result set-nth i 1+ i! ] product-each
|
||||
result
|
||||
] new-like ; inline
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Cartesian products of sequences
|
||||
|
|
@ -224,7 +224,8 @@ void mark_object_code_block(CELL scan)
|
|||
{
|
||||
case WORD_TYPE:
|
||||
word = (F_WORD *)scan;
|
||||
mark_code_block(word->code);
|
||||
if(word->code)
|
||||
mark_code_block(word->code);
|
||||
if(word->profiling)
|
||||
mark_code_block(word->profiling);
|
||||
break;
|
||||
|
|
|
|||
16
vm/code_gc.c
16
vm/code_gc.c
|
|
@ -22,13 +22,13 @@ void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
|
|||
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
|
||||
{
|
||||
int index = block->block.size / BLOCK_SIZE_INCREMENT;
|
||||
block->next_free = heap->free.small[index];
|
||||
heap->free.small[index] = block;
|
||||
block->next_free = heap->free.small_blocks[index];
|
||||
heap->free.small_blocks[index] = block;
|
||||
}
|
||||
else
|
||||
{
|
||||
block->next_free = heap->free.large;
|
||||
heap->free.large = block;
|
||||
block->next_free = heap->free.large_blocks;
|
||||
heap->free.large_blocks = block;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -101,11 +101,11 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
|
|||
while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
|
||||
{
|
||||
int index = attempt / BLOCK_SIZE_INCREMENT;
|
||||
F_FREE_BLOCK *block = heap->free.small[index];
|
||||
F_FREE_BLOCK *block = heap->free.small_blocks[index];
|
||||
if(block)
|
||||
{
|
||||
assert_free_block(block);
|
||||
heap->free.small[index] = block->next_free;
|
||||
heap->free.small_blocks[index] = block->next_free;
|
||||
return block;
|
||||
}
|
||||
|
||||
|
|
@ -113,7 +113,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
|
|||
}
|
||||
|
||||
F_FREE_BLOCK *prev = NULL;
|
||||
F_FREE_BLOCK *block = heap->free.large;
|
||||
F_FREE_BLOCK *block = heap->free.large_blocks;
|
||||
|
||||
while(block)
|
||||
{
|
||||
|
|
@ -123,7 +123,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
|
|||
if(prev)
|
||||
prev->next_free = block->next_free;
|
||||
else
|
||||
heap->free.large = block->next_free;
|
||||
heap->free.large_blocks = block->next_free;
|
||||
return block;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
#define BLOCK_SIZE_INCREMENT 32
|
||||
|
||||
typedef struct {
|
||||
F_FREE_BLOCK *small[FREE_LIST_COUNT];
|
||||
F_FREE_BLOCK *large;
|
||||
F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT];
|
||||
F_FREE_BLOCK *large_blocks;
|
||||
} F_HEAP_FREE_LIST;
|
||||
|
||||
typedef struct {
|
||||
|
|
|
|||
|
|
@ -330,7 +330,7 @@ CELL copy_next_from_tenured(CELL scan)
|
|||
|
||||
void copy_reachable_objects(CELL scan, CELL *end)
|
||||
{
|
||||
if(HAVE_NURSERY_P && collecting_gen == NURSERY)
|
||||
if(collecting_gen == NURSERY)
|
||||
{
|
||||
while(scan < *end)
|
||||
scan = copy_next_from_nursery(scan);
|
||||
|
|
@ -405,7 +405,7 @@ void end_gc(CELL gc_elapsed)
|
|||
if(collecting_gen != NURSERY)
|
||||
reset_generations(NURSERY,collecting_gen - 1);
|
||||
}
|
||||
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
|
||||
else if(collecting_gen == NURSERY)
|
||||
{
|
||||
nursery.here = nursery.start;
|
||||
}
|
||||
|
|
|
|||
20
vm/data_gc.h
20
vm/data_gc.h
|
|
@ -58,7 +58,7 @@ INLINE bool should_copy(CELL untagged)
|
|||
return true;
|
||||
else if(HAVE_AGING_P && collecting_gen == AGING)
|
||||
return !in_zone(&data_heap->generations[TENURED],untagged);
|
||||
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
|
||||
else if(collecting_gen == NURSERY)
|
||||
return in_zone(&nursery,untagged);
|
||||
else
|
||||
{
|
||||
|
|
@ -78,15 +78,31 @@ allocation (which does not call GC because of possible roots in volatile
|
|||
registers) does not run out of memory */
|
||||
#define ALLOT_BUFFER_ZONE 1024
|
||||
|
||||
/* If this is defined, we GC every 100 allocations. This catches missing local roots */
|
||||
#ifdef GC_DEBUG
|
||||
static int count;
|
||||
#endif
|
||||
|
||||
/*
|
||||
* It is up to the caller to fill in the object's fields in a meaningful
|
||||
* fashion!
|
||||
*/
|
||||
INLINE void *allot_object(CELL type, CELL a)
|
||||
{
|
||||
|
||||
#ifdef GC_DEBUG
|
||||
|
||||
if(!gc_off)
|
||||
{
|
||||
if(count++ % 1000 == 0)
|
||||
gc();
|
||||
|
||||
}
|
||||
#endif
|
||||
|
||||
CELL *object;
|
||||
|
||||
if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
|
||||
if(nursery.size - ALLOT_BUFFER_ZONE > a)
|
||||
{
|
||||
/* If there is insufficient room, collect the nursery */
|
||||
if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
|
||||
|
|
|
|||
|
|
@ -37,7 +37,6 @@ F_DATA_HEAP *data_heap;
|
|||
|
||||
/* the 0th generation is where new objects are allocated. */
|
||||
#define NURSERY 0
|
||||
#define HAVE_NURSERY_P (data_heap->gen_count>1)
|
||||
/* where objects hang around */
|
||||
#define AGING (data_heap->gen_count-2)
|
||||
#define HAVE_AGING_P (data_heap->gen_count>2)
|
||||
|
|
|
|||
Loading…
Reference in New Issue