From d5b4202f6a694c7720c0e271fe75a0a59dec1dd9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 13 Oct 2009 17:25:32 -0500 Subject: [PATCH] unbox read-only tuple arguments and box read-only tuple results to TYPED: words in the inlined wrapper code to avoid allocation of unboxable tuples --- extra/typed/typed-tests.factor | 20 +++++++- extra/typed/typed.factor | 94 +++++++++++++++++++++++++--------- 2 files changed, 88 insertions(+), 26 deletions(-) diff --git a/extra/typed/typed-tests.factor b/extra/typed/typed-tests.factor index 2bfd837f30..1d23bd7267 100644 --- a/extra/typed/typed-tests.factor +++ b/extra/typed/typed-tests.factor @@ -1,4 +1,4 @@ -USING: kernel layouts math quotations tools.test typed ; +USING: accessors effects kernel layouts math quotations tools.test typed words ; IN: typed.tests TYPED: f+ ( a: float b: float -- c: float ) @@ -35,3 +35,21 @@ TYPED:: f+locals ( a: float b: float -- c: float ) a b + ; [ 3.5 ] [ 2 1+1/2 f+locals ] unit-test + +TUPLE: unboxable + { x fixnum read-only } + { y fixnum read-only } ; + +TUPLE: unboxable2 + { u unboxable read-only } + { xy fixnum read-only } ; + +TYPED: unboxy ( in: unboxable -- out: unboxable2 ) + dup [ x>> ] [ y>> ] bi - unboxable2 boa ; + +[ (( in: fixnum in: fixnum -- out: fixnum out: fixnum out: fixnum )) ] +[ \ unboxy "typed-word" word-prop stack-effect ] unit-test + +[ T{ unboxable2 { u T{ unboxable { x 12 } { y 3 } } } { xy 9 } } ] +[ T{ unboxable { x 12 } { y 3 } } unboxy ] unit-test + diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor index 3060adea54..385c311eeb 100644 --- a/extra/typed/typed.factor +++ b/extra/typed/typed.factor @@ -1,14 +1,21 @@ ! (c)Joe Groff bsd license -USING: accessors arrays combinators combinators.short-circuit -definitions effects fry hints math kernel kernel.private namespaces -parser quotations see.private sequences words -locals locals.definitions locals.parser ; +USING: accessors arrays classes classes.tuple combinators +combinators.short-circuit definitions effects fry hints +math kernel kernel.private namespaces parser quotations +see.private sequences slots words locals locals.definitions +locals.parser ; IN: typed ERROR: type-mismatch-error word expected-types ; ERROR: input-mismatch-error < type-mismatch-error ; ERROR: output-mismatch-error < type-mismatch-error ; +: unboxable-tuple-class? ( type -- ? ) + { + [ all-slots empty? not ] + [ immutable-tuple-class? ] + } 1&& ; + ! typed inputs : typed-stack-effect? ( effect -- ? ) @@ -17,45 +24,79 @@ ERROR: output-mismatch-error < type-mismatch-error ; : input-mismatch-quot ( word types -- quot ) [ input-mismatch-error ] 2curry ; -: make-coercer ( types -- quot ) - [ "coercer" word-prop [ ] or ] - [ swap \ dip [ ] 2sequence prepend ] - map-reduce ; +: (unboxer) ( type -- quot ) + dup unboxable-tuple-class? [ + all-slots [ + [ name>> reader-word 1quotation ] + [ class>> (unboxer) ] bi compose + ] map [ cleave ] curry + ] [ drop [ ] ] if ; -: typed-inputs ( quot word types -- quot' ) - { - [ 2nip make-coercer ] - [ 2nip make-specializer ] - [ nip swap '[ _ declare @ ] ] - [ [ drop ] 2dip input-mismatch-quot ] - } 3cleave '[ @ @ _ _ if ] ; +:: unboxer ( error-quot word types type -- quot ) + type "coercer" word-prop [ ] or + [ dup type instance? [ word types error-quot call ] unless ] + type (unboxer) + compose compose ; + +: make-unboxer ( error-quot word types -- quot ) + dup [ unboxer ] with with with + [ swap \ dip [ ] 2sequence prepend ] map-reduce ; + +: (unboxed-types) ( type -- types ) + dup unboxable-tuple-class? + [ all-slots [ class>> (unboxed-types) ] map concat ] + [ 1array ] if ; + +: unboxed-types ( types -- types' ) + [ (unboxed-types) ] map concat ; + +:: typed-inputs ( quot word types -- quot' ) + types unboxed-types :> unboxed-types + + [ input-mismatch-error ] word types make-unboxer + unboxed-types quot '[ _ declare @ ] + compose ; ! typed outputs : output-mismatch-quot ( word types -- quot ) [ output-mismatch-error ] 2curry ; -: typed-outputs ( quot word types -- quot' ) - { - [ 2drop ] - [ 2nip make-coercer ] - [ 2nip make-specializer ] - [ [ drop ] 2dip output-mismatch-quot ] - } 3cleave '[ @ @ @ _ unless ] ; +:: typed-outputs ( quot word types -- quot' ) + [ output-mismatch-error ] word types make-unboxer + quot prepose ; + +DEFER: make-boxer + +: boxer ( type -- quot ) + dup unboxable-tuple-class? + [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ] + [ drop [ ] ] if ; + +: make-boxer ( types -- quot ) + [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ; ! defining typed words : typed-gensym-quot ( def word effect -- quot ) - [ nip effect-in-types swap '[ _ declare @ ] ] + [ + nip effect-in-types swap + [ [ unboxed-types ] [ make-boxer ] bi ] dip + '[ _ declare @ @ ] + ] [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ; : typed-gensym ( parent-word -- word ) name>> "( typed " " )" surround f ; +: unboxed-effect ( effect -- effect' ) + [ effect-in-types unboxed-types [ "in" swap 2array ] map ] + [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi ; + : define-typed-gensym ( word def effect -- gensym ) [ 2drop typed-gensym dup ] [ [ swap ] dip typed-gensym-quot ] - [ 2nip ] 3tri define-declared ; + [ 2nip unboxed-effect ] 3tri define-declared ; PREDICATE: typed-standard-word < word "typed-word" word-prop ; PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ; @@ -64,7 +105,10 @@ UNION: typed-word typed-standard-word typed-lambda-word ; : typed-quot ( quot word effect -- quot' ) [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] - [ nip effect-out-types dup typed-stack-effect? [ '[ @ _ declare ] ] [ drop ] if ] 2bi ; + [ + nip effect-out-types dup typed-stack-effect? + [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if + ] 2bi ; : (typed-def) ( word def effect -- quot ) [ define-typed-gensym ] 3keep