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

@@ -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
+

extra/typed/typed.factor

@@ -1,14 +1,21 @@
 ! (c)Joe Groff bsd license
-USING: accessors arrays combinators combinators.short-circuit
+USING: accessors arrays classes classes.tuple combinators
-definitions effects fry hints math kernel kernel.private namespaces
+combinators.short-circuit definitions effects fry hints
-parser quotations see.private sequences words
+math kernel kernel.private namespaces parser quotations
-locals locals.definitions locals.parser ;
+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 )
+: (unboxer) ( type -- quot )
-    [ "coercer" word-prop [ ] or ]
+    dup unboxable-tuple-class? [
-    [ swap \ dip [ ] 2sequence prepend ]
+        all-slots [
-    map-reduce ;
+            [ name>> reader-word 1quotation ]
+            [ class>> (unboxer) ] bi compose
+        ] map [ cleave ] curry
+    ] [ drop [ ] ] if ;
 
-: typed-inputs ( quot word types -- quot' )
+:: unboxer ( error-quot word types type -- quot )
-    {
+    type "coercer" word-prop [ ] or
-        [ 2nip make-coercer ]
+    [ dup type instance? [ word types error-quot call ] unless ]
-        [ 2nip make-specializer ]
+    type (unboxer)
-        [ nip swap '[ _ declare @ ] ]
+    compose compose ;
-        [ [ drop ] 2dip input-mismatch-quot ]
+
-    } 3cleave '[ @ @ _ _ if ] ;
+: 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' )
+:: typed-outputs ( quot word types -- quot' )
-    {
+    [ output-mismatch-error ] word types make-unboxer
-        [ 2drop ]
+    quot prepose ;
-        [ 2nip make-coercer ]
+
-        [ 2nip make-specializer ]
+DEFER: make-boxer
-        [ [ drop ] 2dip output-mismatch-quot ]
+
-    } 3cleave '[ @ @ @ _ unless ] ;
+: 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 <word> ;
 
+: unboxed-effect ( effect -- effect' )
+    [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
+    [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
+
 : 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