Alien unboxing
Slava Pestov
parent
07c4da864e
commit
894a657056
|
|
@ -4,6 +4,8 @@ USING: compiler generator generator.registers
|
|||
generator.registers.private tools.test namespaces sequences
|
||||
words kernel math effects ;
|
||||
|
||||
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
|
||||
|
||||
[
|
||||
[ ] [ init-templates ] unit-test
|
||||
|
||||
|
|
@ -58,8 +60,6 @@ words kernel math effects ;
|
|||
{ +input+ { { f "x" } } }
|
||||
} clone [
|
||||
[ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
|
||||
[ ] [ 1 0 ensure-vregs ] unit-test
|
||||
! [ t ] [ +input+ get phantom-d get compatible? ] unit-test
|
||||
[ ] [ finalize-contents ] unit-test
|
||||
[ ] [ [ template-inputs ] { } make drop ] unit-test
|
||||
] bind
|
||||
|
|
@ -119,12 +119,14 @@ SYMBOL: template-chosen
|
|||
|
||||
! This is not empty since a load instruction is emitted
|
||||
[ f ] [
|
||||
[ { { f "x" } } fast-input ] { } make empty?
|
||||
[ { { f "x" } } +input+ set load-inputs ] { } make
|
||||
empty?
|
||||
] unit-test
|
||||
|
||||
! This is empty since we already loaded the value
|
||||
[ t ] [
|
||||
[ { { f "x" } } fast-input ] { } make empty?
|
||||
[ { { f "x" } } +input+ set load-inputs ] { } make
|
||||
empty?
|
||||
] unit-test
|
||||
|
||||
! This is empty since we didn't change the stack
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic kernel kernel.private math memory
|
||||
namespaces sequences layouts system hashtables classes alien
|
||||
byte-arrays bit-arrays float-arrays combinators words
|
||||
inference.dataflow ;
|
||||
byte-arrays bit-arrays float-arrays combinators words ;
|
||||
IN: cpu.architecture
|
||||
|
||||
SYMBOL: compiler-backend
|
||||
|
|
@ -153,8 +152,6 @@ M: integer v>operand tag-bits get shift ;
|
|||
|
||||
M: f v>operand drop \ f tag-number ;
|
||||
|
||||
M: value v>operand value-literal ;
|
||||
|
||||
M: object load-literal v>operand load-indirect ;
|
||||
|
||||
PREDICATE: integer small-slot cells small-enough? ;
|
||||
|
|
@ -189,7 +186,7 @@ HOOK: %unbox-alien compiler-backend ( dst src -- )
|
|||
|
||||
HOOK: %unbox-f compiler-backend ( dst src -- )
|
||||
|
||||
HOOK: %unbox-c-ptr compiler-backend ( dst src -- )
|
||||
HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
|
||||
|
||||
HOOK: %box-alien compiler-backend ( dst src -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -269,7 +269,7 @@ M: ppc-backend %alien-invoke ( symbol dll -- )
|
|||
11 %load-dlsym (%call) ;
|
||||
|
||||
M: ppc-backend %alien-callback ( quot -- )
|
||||
0 <int-vreg> load-literal "c_to_factor" f %alien-invoke ;
|
||||
3 load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: ppc-backend %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
|
|
@ -324,7 +324,7 @@ M: ppc-backend %unbox-alien ( dst src -- )
|
|||
M: ppc-backend %unbox-f ( dst src -- )
|
||||
drop 0 swap v>operand LI ;
|
||||
|
||||
M: ppc-backend %unbox-c-ptr ( dst src -- )
|
||||
M: ppc-backend %unbox-any-c-ptr ( dst src -- )
|
||||
"is-f" define-label
|
||||
"is-alien" define-label
|
||||
"end" define-label
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: cpu.ppc.intrinsics
|
|||
"val" operand
|
||||
"obj" operand
|
||||
"n" get cells
|
||||
"obj" operand-tag - ;
|
||||
"obj" get operand-tag - ;
|
||||
|
||||
: %slot-literal-any-tag
|
||||
"obj" operand "scratch" operand %untag
|
||||
|
|
@ -58,7 +58,7 @@ IN: cpu.ppc.intrinsics
|
|||
"cards_offset" f pick %load-dlsym dup 0 LWZ ;
|
||||
|
||||
: %write-barrier ( -- )
|
||||
"val" operand-immediate? "obj" get fresh-object? or [
|
||||
"val" get operand-immediate? "obj" get fresh-object? or [
|
||||
"obj" operand "scratch" operand card-bits SRWI
|
||||
"val" operand load-cards-offset
|
||||
"scratch" operand dup "val" operand ADD
|
||||
|
|
@ -674,8 +674,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" simple-c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
! should be unboxed-alien
|
||||
{ +scratch+ { { unboxed-c-ptr "output" } } }
|
||||
{ +scratch+ { { unboxed-alien "output" } } }
|
||||
{ +output+ { "output" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} define-intrinsic
|
||||
|
|
|
|||
|
|
@ -51,3 +51,18 @@ M: integer (stack-picture) drop "object" ;
|
|||
|
||||
M: effect clone
|
||||
[ effect-in clone ] keep effect-out clone <effect> ;
|
||||
|
||||
: split-shuffle ( stack shuffle -- stack1 stack2 )
|
||||
effect-in length swap cut* ;
|
||||
|
||||
: load-shuffle ( stack shuffle -- )
|
||||
effect-in [ set ] 2each ;
|
||||
|
||||
: shuffled-values ( shuffle -- values )
|
||||
effect-out [ get ] map ;
|
||||
|
||||
: shuffle* ( stack shuffle -- newstack )
|
||||
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
|
||||
|
||||
: shuffle ( stack shuffle -- newstack )
|
||||
[ split-shuffle ] keep shuffle* append ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes combinators cpu.architecture
|
||||
effects generator.fixup generator.registers generic hashtables
|
||||
inference inference.backend inference.dataflow inference.stack
|
||||
io kernel kernel.private layouts math namespaces optimizer
|
||||
prettyprint quotations sequences system threads words ;
|
||||
inference inference.backend inference.dataflow io kernel
|
||||
kernel.private layouts math namespaces optimizer prettyprint
|
||||
quotations sequences system threads words ;
|
||||
IN: generator
|
||||
|
||||
SYMBOL: compiled-xts
|
||||
|
|
@ -246,10 +246,8 @@ M: #dispatch generate-node
|
|||
: define-if-intrinsic ( word quot inputs -- )
|
||||
2array 1array define-if-intrinsics ;
|
||||
|
||||
: do-intrinsic ( pair -- ) first2 with-template ;
|
||||
|
||||
: do-if-intrinsic ( #call pair -- next )
|
||||
<label> [ swap do-intrinsic ] keep
|
||||
<label> [ swap do-template ] keep
|
||||
>r node-successor r> generate-if
|
||||
node-successor ;
|
||||
|
||||
|
|
@ -264,11 +262,12 @@ M: #dispatch generate-node
|
|||
] if ;
|
||||
|
||||
M: #call generate-node
|
||||
dup node-input-classes set-operand-classes
|
||||
dup find-if-intrinsic [
|
||||
do-if-intrinsic
|
||||
] [
|
||||
dup find-intrinsic [
|
||||
do-intrinsic iterate-next
|
||||
do-template iterate-next
|
||||
] [
|
||||
node-param generate-call
|
||||
] ?if
|
||||
|
|
@ -278,10 +277,9 @@ M: #call generate-node
|
|||
M: #call-label generate-node node-param generate-call ;
|
||||
|
||||
! #push
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
M: #push generate-node
|
||||
node-out-d [ phantom-push ] each iterate-next ;
|
||||
node-out-d [ value-literal <constant> phantom-push ] each
|
||||
iterate-next ;
|
||||
|
||||
! #shuffle
|
||||
M: #shuffle generate-node
|
||||
|
|
@ -313,6 +311,3 @@ M: #return generate-node drop end-basic-block %return f ;
|
|||
: alien-offset 3 cells object tag-number - ;
|
||||
: tuple-class-offset 2 cells tuple tag-number - ;
|
||||
: class-hash-offset cell object tag-number - ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class< ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes classes.private combinators
|
||||
cpu.architecture generator.fixup generic hashtables
|
||||
inference.dataflow inference.stack kernel kernel.private layouts
|
||||
math memory namespaces quotations sequences system vectors words
|
||||
effects ;
|
||||
cpu.architecture generator.fixup hashtables kernel layouts math
|
||||
namespaces quotations sequences system vectors words effects
|
||||
alien byte-arrays bit-arrays float-arrays ;
|
||||
IN: generator.registers
|
||||
|
||||
SYMBOL: +input+
|
||||
|
|
@ -13,83 +12,205 @@ SYMBOL: +scratch+
|
|||
SYMBOL: +clobber+
|
||||
SYMBOL: known-tag
|
||||
|
||||
! Register classes
|
||||
TUPLE: int-regs ;
|
||||
|
||||
TUPLE: float-regs size ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Value protocol
|
||||
GENERIC: set-operand-class ( class obj -- )
|
||||
GENERIC: operand-class* ( operand -- class )
|
||||
GENERIC: move-spec ( obj -- spec )
|
||||
GENERIC: live-vregs* ( obj -- )
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
GENERIC# (lazy-load) 1 ( value spec -- value )
|
||||
GENERIC: lazy-store ( dst src -- )
|
||||
GENERIC: minimal-ds-loc* ( min obj -- min )
|
||||
|
||||
! This will be a multimethod soon
|
||||
DEFER: %move
|
||||
|
||||
MIXIN: value
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: operand-class ( operand -- class )
|
||||
operand-class* object or ;
|
||||
|
||||
! Default implementation
|
||||
M: value set-operand-class 2drop ;
|
||||
M: value operand-class* drop f ;
|
||||
M: value live-vregs* drop ;
|
||||
M: value live-loc? 2drop f ;
|
||||
M: value minimal-ds-loc* drop ;
|
||||
M: value lazy-store 2drop ;
|
||||
|
||||
! A scratch register for computations
|
||||
TUPLE: vreg n ;
|
||||
|
||||
: <vreg> ( n reg-class -- vreg )
|
||||
{ set-vreg-n set-delegate } vreg construct ;
|
||||
|
||||
! Register classes
|
||||
TUPLE: int-regs ;
|
||||
TUPLE: float-regs size ;
|
||||
M: vreg v>operand dup vreg-n swap vregs nth ;
|
||||
M: vreg live-vregs* , ;
|
||||
|
||||
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
|
||||
: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
|
||||
INSTANCE: vreg value
|
||||
|
||||
M: float-regs move-spec drop float ;
|
||||
M: float-regs operand-class* drop float ;
|
||||
|
||||
! Temporary register for stack shuffling
|
||||
TUPLE: temp-reg ;
|
||||
|
||||
: temp-reg T{ temp-reg T{ int-regs } } ;
|
||||
|
||||
M: vreg v>operand dup vreg-n swap vregs nth ;
|
||||
M: temp-reg move-spec drop f ;
|
||||
|
||||
INSTANCE: temp-reg value
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n class ;
|
||||
|
||||
: <ds-loc> { set-ds-loc-n } ds-loc construct ;
|
||||
|
||||
M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||
M: ds-loc operand-class* ds-loc-class ;
|
||||
M: ds-loc set-operand-class set-ds-loc-class ;
|
||||
|
||||
! A retain stack location.
|
||||
TUPLE: rs-loc n class ;
|
||||
|
||||
: <rs-loc> { set-rs-loc-n } rs-loc construct ;
|
||||
|
||||
M: rs-loc operand-class* rs-loc-class ;
|
||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||
|
||||
UNION: loc ds-loc rs-loc ;
|
||||
|
||||
M: loc move-spec drop loc ;
|
||||
M: loc live-loc? = not ;
|
||||
|
||||
INSTANCE: loc value
|
||||
|
||||
M: f move-spec drop loc ;
|
||||
M: f operand-class* ;
|
||||
|
||||
! A stack location which has been loaded into a register. To
|
||||
! read the location, we just read the register, but when time
|
||||
! comes to save it back to the stack, we know the register just
|
||||
! contains a stack value so we don't have to redundantly write
|
||||
! it back.
|
||||
TUPLE: cached loc vreg ;
|
||||
|
||||
C: <cached> cached
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n ;
|
||||
M: cached set-operand-class cached-vreg set-operand-class ;
|
||||
M: cached operand-class* cached-vreg operand-class* ;
|
||||
M: cached move-spec drop cached ;
|
||||
M: cached live-vregs* cached-vreg live-vregs* ;
|
||||
M: cached live-loc? cached-loc live-loc? ;
|
||||
M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
|
||||
M: cached lazy-store
|
||||
2dup cached-loc = [ 2drop ] [ cached-vreg %move ] if ;
|
||||
M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
|
||||
|
||||
C: <ds-loc> ds-loc
|
||||
INSTANCE: cached value
|
||||
|
||||
! A retain stack location.
|
||||
TUPLE: rs-loc n ;
|
||||
! A tagged pointer
|
||||
TUPLE: tagged vreg class ;
|
||||
|
||||
C: <rs-loc> rs-loc
|
||||
: <tagged> ( vreg -- tagged )
|
||||
{ set-tagged-vreg } tagged construct ;
|
||||
|
||||
M: tagged v>operand tagged-vreg v>operand ;
|
||||
M: tagged set-operand-class set-tagged-class ;
|
||||
M: tagged operand-class* tagged-class ;
|
||||
M: tagged move-spec drop f ;
|
||||
M: tagged live-vregs* tagged-vreg , ;
|
||||
|
||||
INSTANCE: tagged value
|
||||
|
||||
! Unboxed alien pointers
|
||||
TUPLE: unboxed-alien vreg ;
|
||||
C: <unboxed-alien> unboxed-alien
|
||||
M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
|
||||
M: unboxed-alien operand-class* drop simple-alien ;
|
||||
M: unboxed-alien move-spec class ;
|
||||
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-alien value
|
||||
|
||||
TUPLE: unboxed-byte-array vreg ;
|
||||
C: <unboxed-byte-array> unboxed-byte-array
|
||||
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
|
||||
M: unboxed-byte-array operand-class* drop simple-c-ptr ;
|
||||
M: unboxed-byte-array move-spec class ;
|
||||
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-byte-array value
|
||||
|
||||
TUPLE: unboxed-f vreg ;
|
||||
C: <unboxed-f> unboxed-f
|
||||
M: unboxed-f v>operand unboxed-f-vreg v>operand ;
|
||||
M: unboxed-f operand-class* drop \ f ;
|
||||
M: unboxed-f move-spec class ;
|
||||
M: unboxed-f live-vregs* unboxed-f-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-f value
|
||||
|
||||
TUPLE: unboxed-c-ptr vreg ;
|
||||
C: <unboxed-c-ptr> unboxed-c-ptr
|
||||
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
|
||||
M: unboxed-c-ptr operand-class* drop simple-c-ptr ;
|
||||
M: unboxed-c-ptr move-spec class ;
|
||||
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-c-ptr value
|
||||
|
||||
! A constant value
|
||||
TUPLE: constant value ;
|
||||
C: <constant> constant
|
||||
M: constant operand-class* constant-value class ;
|
||||
M: constant move-spec class ;
|
||||
|
||||
INSTANCE: constant value
|
||||
|
||||
<PRIVATE
|
||||
|
||||
UNION: loc ds-loc rs-loc ;
|
||||
|
||||
! Moving values between locations and registers
|
||||
GENERIC: move-spec ( obj -- spec )
|
||||
: %move-bug "Bug in generator.registers" throw ;
|
||||
|
||||
M: unboxed-alien move-spec class ;
|
||||
M: unboxed-byte-array move-spec class ;
|
||||
M: unboxed-f move-spec class ;
|
||||
M: unboxed-c-ptr move-spec class ;
|
||||
M: int-regs move-spec drop f ;
|
||||
M: float-regs move-spec drop float ;
|
||||
M: value move-spec class ;
|
||||
M: cached move-spec drop cached ;
|
||||
M: loc move-spec drop loc ;
|
||||
M: f move-spec drop loc ;
|
||||
: %unbox-c-ptr ( dst src -- )
|
||||
dup operand-class {
|
||||
{ [ dup \ f class< ] [ drop %unbox-f ] }
|
||||
{ [ dup simple-alien class< ] [ drop %unbox-alien ] }
|
||||
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ t ] [ drop %unbox-any-c-ptr ] }
|
||||
} cond ; inline
|
||||
|
||||
: %move-via-temp ( dst src -- )
|
||||
#! For many transfers, such as loc to unboxed-alien, we
|
||||
#! don't have an intrinsic, so we transfer the source to
|
||||
#! temp then temp to the destination.
|
||||
temp-reg over %move
|
||||
operand-class temp-reg
|
||||
{ set-operand-class set-tagged-vreg } tagged construct
|
||||
%move ;
|
||||
|
||||
: %move ( dst src -- )
|
||||
2dup [ move-spec ] 2apply 2array {
|
||||
{ { f f } [ "Bug in generator.registers %move" throw ] }
|
||||
{ { f value } [ value-literal swap load-literal ] }
|
||||
{ { f f } [ %move-bug ] }
|
||||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||
|
||||
{ { f constant } [ constant-value swap load-literal ] }
|
||||
|
||||
{ { f float } [ %box-float ] }
|
||||
! { { f unboxed-alien } [ %box-alien ] }
|
||||
{ { f unboxed-c-ptr } [ %box-alien ] }
|
||||
{ { f unboxed-alien } [ %box-alien ] }
|
||||
{ { f loc } [ %peek ] }
|
||||
|
||||
{ { float f } [ %unbox-float ] }
|
||||
|
|
@ -99,7 +220,7 @@ M: f move-spec drop loc ;
|
|||
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
|
||||
{ { loc f } [ swap %replace ] }
|
||||
|
||||
[ drop temp-reg swap %move temp-reg %move ]
|
||||
[ drop %move-via-temp ]
|
||||
} case ;
|
||||
|
||||
! A compile-time stack
|
||||
|
|
@ -176,37 +297,20 @@ M: phantom-stack cut-phantom
|
|||
: phantom-append ( seq stack -- )
|
||||
over length over adjust-phantom push-all ;
|
||||
|
||||
: add-locs ( n phantom -- )
|
||||
2dup length <= [
|
||||
2drop
|
||||
] [
|
||||
[ phantom-locs ] keep
|
||||
[ length head-slice* ] keep
|
||||
[ append >vector ] keep
|
||||
delegate set-delegate
|
||||
] if ;
|
||||
|
||||
: phantom-input ( n phantom -- seq )
|
||||
[
|
||||
2dup length <= [
|
||||
cut-phantom
|
||||
] [
|
||||
[ phantom-locs ] keep
|
||||
[ length head-slice* ] keep
|
||||
[ append ] keep
|
||||
delete-all
|
||||
] if
|
||||
] 2keep >r neg r> adjust-phantom ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: phantom-push ( obj -- )
|
||||
1 phantom-d get adjust-phantom
|
||||
phantom-d get push ;
|
||||
|
||||
: phantom-shuffle ( shuffle -- )
|
||||
[ effect-in length phantom-d get phantom-input ] keep
|
||||
shuffle* phantom-d get phantom-append ;
|
||||
|
||||
: phantom->r ( n -- )
|
||||
phantom-d get phantom-input
|
||||
phantom-r get phantom-append ;
|
||||
|
||||
: phantom-r> ( n -- )
|
||||
phantom-r get phantom-input
|
||||
phantom-d get phantom-append ;
|
||||
|
||||
<PRIVATE
|
||||
2dup add-locs
|
||||
2dup cut-phantom
|
||||
>r >r neg r> adjust-phantom r> ;
|
||||
|
||||
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
|
||||
|
||||
|
|
@ -214,26 +318,9 @@ PRIVATE>
|
|||
|
||||
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
||||
|
||||
! Phantom stacks hold values, locs, and vregs
|
||||
GENERIC: live-vregs* ( obj -- )
|
||||
|
||||
M: cached live-vregs* cached-vreg live-vregs* ;
|
||||
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
|
||||
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
|
||||
M: unboxed-f live-vregs* unboxed-f-vreg , ;
|
||||
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
|
||||
M: vreg live-vregs* , ;
|
||||
M: object live-vregs* drop ;
|
||||
|
||||
: live-vregs ( -- seq )
|
||||
[ [ [ live-vregs* ] each ] each-phantom ] { } make ;
|
||||
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
|
||||
M: cached live-loc? cached-loc live-loc? ;
|
||||
M: loc live-loc? = not ;
|
||||
M: object live-loc? 2drop f ;
|
||||
|
||||
: (live-locs) ( phantom -- seq )
|
||||
#! Discard locs which haven't moved
|
||||
dup phantom-locs* swap 2array flip
|
||||
|
|
@ -248,10 +335,51 @@ M: object live-loc? 2drop f ;
|
|||
SYMBOL: fresh-objects
|
||||
|
||||
! Computing free registers and initializing allocator
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq?
|
||||
T{ float-regs f 8 } T{ int-regs } ? ;
|
||||
|
||||
: free-vregs ( reg-class -- seq )
|
||||
#! Free vregs in a given register class
|
||||
\ free-vregs get at ;
|
||||
|
||||
: alloc-vreg ( spec -- reg )
|
||||
dup reg-spec>class free-vregs pop swap {
|
||||
{ f [ <tagged> ] }
|
||||
{ unboxed-alien [ <unboxed-alien> ] }
|
||||
{ unboxed-byte-array [ <unboxed-byte-array> ] }
|
||||
{ unboxed-f [ <unboxed-f> ] }
|
||||
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: compatible? ( value spec -- ? )
|
||||
>r move-spec r> {
|
||||
{ [ 2dup = ] [ t ] }
|
||||
{ [ dup unboxed-c-ptr eq? ] [
|
||||
over { unboxed-byte-array unboxed-alien } member?
|
||||
] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond 2nip ;
|
||||
|
||||
: allocation ( value spec -- reg-class )
|
||||
{
|
||||
{ [ dup quotation? ] [ 2drop f ] }
|
||||
{ [ 2dup compatible? ] [ 2drop f ] }
|
||||
{ [ t ] [ nip reg-spec>class ] }
|
||||
} cond ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
swap operand-class swap alloc-vreg
|
||||
dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
|
||||
|
||||
M: value (lazy-load)
|
||||
2dup allocation [
|
||||
dupd alloc-vreg-for dup rot %move
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: (compute-free-vregs) ( used class -- vector )
|
||||
#! Find all vregs in 'class' which are not in 'used'.
|
||||
[ vregs length reverse ] keep
|
||||
|
|
@ -266,55 +394,14 @@ SYMBOL: fresh-objects
|
|||
\ free-vregs set
|
||||
drop ;
|
||||
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq?
|
||||
T{ float-regs f 8 } T{ int-regs } ? ;
|
||||
|
||||
! Copying vregs to stacks
|
||||
: alloc-vreg ( spec -- reg )
|
||||
dup reg-spec>class free-vregs pop swap {
|
||||
{ unboxed-alien [ <unboxed-alien> ] }
|
||||
{ unboxed-byte-array [ <unboxed-byte-array> ] }
|
||||
{ unboxed-f [ <unboxed-f> ] }
|
||||
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: allocation ( value spec -- reg-class )
|
||||
dup quotation? [
|
||||
2drop f
|
||||
] [
|
||||
dup rot move-spec = [
|
||||
drop f
|
||||
] [
|
||||
reg-spec>class
|
||||
] if
|
||||
] if ;
|
||||
|
||||
GENERIC# (lazy-load) 1 ( value spec -- value )
|
||||
|
||||
M: cached (lazy-load)
|
||||
>r cached-vreg r> (lazy-load) ;
|
||||
|
||||
M: object (lazy-load)
|
||||
2dup allocation [ alloc-vreg dup rot %move ] [ drop ] if ;
|
||||
|
||||
GENERIC: lazy-store ( dst src -- )
|
||||
|
||||
M: loc lazy-store
|
||||
2dup = [ 2drop ] [ \ live-locs get at %move ] if ;
|
||||
|
||||
M: cached lazy-store
|
||||
2dup cached-loc = [ 2drop ] [ cached-vreg %move ] if ;
|
||||
|
||||
M: object lazy-store
|
||||
2drop ;
|
||||
2dup = [ 2drop ] [ "live-locs" get at %move ] if ;
|
||||
|
||||
: do-shuffle ( hash -- )
|
||||
dup assoc-empty? [
|
||||
drop
|
||||
] [
|
||||
\ live-locs set
|
||||
"live-locs" set
|
||||
[ lazy-store ] each-loc
|
||||
] if ;
|
||||
|
||||
|
|
@ -323,12 +410,6 @@ M: object lazy-store
|
|||
#! at once
|
||||
[ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
|
||||
|
||||
GENERIC: minimal-ds-loc* ( min obj -- min )
|
||||
|
||||
M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
|
||||
M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||
M: object minimal-ds-loc* drop ;
|
||||
|
||||
: minimal-ds-loc ( phantom -- n )
|
||||
#! When shuffling more values than can fit in registers, we
|
||||
#! need to find an area on the data stack which isn't in
|
||||
|
|
@ -380,60 +461,42 @@ M: object minimal-ds-loc* drop ;
|
|||
"simple_gc" f %alien-invoke ;
|
||||
|
||||
! Loading stacks to vregs
|
||||
: free-vregs# ( -- int# float# )
|
||||
T{ int-regs } T{ float-regs f 8 }
|
||||
[ free-vregs length ] 2apply ;
|
||||
|
||||
: free-vregs? ( int# float# -- ? )
|
||||
free-vregs# swapd <= >r <= r> and ;
|
||||
|
||||
: ensure-vregs ( int# float# -- )
|
||||
compute-free-vregs free-vregs?
|
||||
[ finalize-contents compute-free-vregs ] unless ;
|
||||
T{ float-regs f 8 } free-vregs length <
|
||||
>r T{ int-regs } free-vregs length < r> and ;
|
||||
|
||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||
0 <column>
|
||||
[ length f pad-left ] keep
|
||||
[ <reversed> ] 2apply ; inline
|
||||
|
||||
: phantom&spec-agree? ( phantom spec quot -- ? )
|
||||
>r phantom&spec r> 2all? ; inline
|
||||
|
||||
: split-template ( input -- slow fast )
|
||||
phantom-d get
|
||||
2dup [ length ] 2apply <=
|
||||
[ drop { } swap ] [ length swap cut* ] if ;
|
||||
|
||||
: vreg-substitution ( value vreg -- pair )
|
||||
dupd <cached> 2array ;
|
||||
|
||||
: substitute-vreg? ( old new -- ? )
|
||||
#! We don't substitute locs for float or alien vregs,
|
||||
#! since in those cases the boxing overhead might kill us.
|
||||
cached-vreg {
|
||||
{ [ dup vreg? not ] [ f ] }
|
||||
{ [ dup delegate int-regs? not ] [ f ] }
|
||||
{ [ over loc? not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
} cond 2nip ;
|
||||
cached-vreg tagged? >r loc? r> and ;
|
||||
|
||||
: substitute-vregs ( values vregs -- )
|
||||
[ vreg-substitution ] 2map
|
||||
[ substitute-vreg? ] assoc-subset >hashtable
|
||||
[ swap substitute ] curry each-phantom ;
|
||||
|
||||
: set-operand ( value var -- )
|
||||
>r dup constant? [ constant-value ] when r> set ;
|
||||
|
||||
: lazy-load ( values template -- )
|
||||
#! Set operand vars here.
|
||||
2dup [ first (lazy-load) ] 2map dup rot
|
||||
[ >r dup value? [ value-literal ] when r> second set ] 2each
|
||||
2dup [ first (lazy-load) ] 2map
|
||||
dup rot [ second set-operand ] 2each
|
||||
substitute-vregs ;
|
||||
|
||||
: fast-input ( template -- )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
dup length phantom-d get phantom-input swap lazy-load
|
||||
] if ;
|
||||
: load-inputs ( -- )
|
||||
+input+ get dup length phantom-d get phantom-input
|
||||
swap lazy-load ;
|
||||
|
||||
: output-vregs ( -- seq seq )
|
||||
+output+ +clobber+ [ get [ get ] map ] 2apply ;
|
||||
|
|
@ -446,9 +509,6 @@ M: object minimal-ds-loc* drop ;
|
|||
: outputs-clash? ( -- ? )
|
||||
output-vregs append clash? ;
|
||||
|
||||
: slow-input ( template -- )
|
||||
outputs-clash? [ finalize-contents ] when fast-input ;
|
||||
|
||||
: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
|
||||
|
||||
: count-input-vregs ( phantom spec -- )
|
||||
|
|
@ -477,14 +537,12 @@ M: object minimal-ds-loc* drop ;
|
|||
+input+ get { } +scratch+ get guess-vregs ;
|
||||
|
||||
: template-inputs ( -- )
|
||||
! Ensure we have enough to hold any new stack elements we
|
||||
! will read (if any), and scratch.
|
||||
guess-template-vregs ensure-vregs
|
||||
! Split the template into available (fast) parts and those
|
||||
! that require allocating registers and reading the stack
|
||||
+input+ get split-template fast-input slow-input
|
||||
! Finally allocate scratch registers
|
||||
alloc-scratch ;
|
||||
! Load input values into registers
|
||||
load-inputs
|
||||
! Allocate scratch registers
|
||||
alloc-scratch
|
||||
! If outputs clash, we write values back to the stack
|
||||
outputs-clash? [ finalize-contents ] when ;
|
||||
|
||||
: template-outputs ( -- )
|
||||
+output+ get [ get ] map phantom-d get phantom-append ;
|
||||
|
|
@ -496,16 +554,12 @@ M: object minimal-ds-loc* drop ;
|
|||
#! spec is not a quotation, its a reg-class, in which case
|
||||
#! the value is always good.
|
||||
dup quotation? [
|
||||
over value?
|
||||
[ >r value-literal r> call ] [ 2drop f ] if
|
||||
over constant?
|
||||
[ >r constant-value r> call ] [ 2drop f ] if
|
||||
] [
|
||||
2drop t
|
||||
] if ;
|
||||
|
||||
: template-specs-match? ( -- ? )
|
||||
phantom-d get +input+ get
|
||||
[ value-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: class-tag ( class -- tag/f )
|
||||
dup hi-tag class< [
|
||||
drop object tag-number
|
||||
|
|
@ -514,32 +568,42 @@ M: object minimal-ds-loc* drop ;
|
|||
dup length 1 = [ first tag-number ] [ drop f ] if
|
||||
] if ;
|
||||
|
||||
: class-match? ( actual expected -- ? )
|
||||
: class-matches? ( actual expected -- ? )
|
||||
{
|
||||
{ f [ drop t ] }
|
||||
{ known-tag [ class-tag >boolean ] }
|
||||
[ class< ]
|
||||
} case ;
|
||||
|
||||
: template-classes-match? ( -- ? )
|
||||
#! Depends on node@
|
||||
node@ node-input-classes +input+ get
|
||||
[ 2 swap ?nth class-match? ] 2all? ;
|
||||
: spec-matches? ( value spec -- ? )
|
||||
2dup first value-matches?
|
||||
>r >r operand-class 2 r> ?nth class-matches? r> and ;
|
||||
|
||||
: template-specs-match? ( -- ? )
|
||||
phantom-d get +input+ get
|
||||
[ spec-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: template-matches? ( spec -- ? )
|
||||
#! Depends on node@
|
||||
clone [
|
||||
template-specs-match?
|
||||
template-classes-match? and
|
||||
[ guess-template-vregs free-vregs? ] [ f ] if
|
||||
] bind ;
|
||||
|
||||
: (find-template) ( templates -- pair/f )
|
||||
#! Depends on node@
|
||||
[ second template-matches? ] find nip ;
|
||||
|
||||
: ensure-template-vregs ( -- )
|
||||
guess-template-vregs free-vregs? [
|
||||
finalize-contents compute-free-vregs
|
||||
] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: set-operand-classes ( classes -- )
|
||||
phantom-d get
|
||||
over length over add-locs
|
||||
[ set-operand-class ] 2reverse-each ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
#! in-memory data and retain stacks are up to date with
|
||||
|
|
@ -547,10 +611,18 @@ PRIVATE>
|
|||
finalize-contents finalize-heights
|
||||
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
|
||||
|
||||
: with-template ( quot hash -- )
|
||||
: do-template ( pair -- )
|
||||
#! Use with return value from find-template
|
||||
first2
|
||||
clone [ template-inputs call template-outputs ] bind
|
||||
compute-free-vregs ;
|
||||
inline
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: with-template ( quot hash -- )
|
||||
clone [
|
||||
ensure-template-vregs
|
||||
template-inputs call template-outputs
|
||||
] bind
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
||||
|
||||
|
|
@ -573,17 +645,31 @@ PRIVATE>
|
|||
|
||||
: find-template ( templates -- pair/f )
|
||||
#! Pair has shape { quot hash }
|
||||
#! Depends on node@
|
||||
compute-free-vregs
|
||||
dup (find-template) [ ] [
|
||||
finalize-contents (find-template)
|
||||
] ?if ;
|
||||
|
||||
: operand-class ( operand -- class )
|
||||
#! Depends on node@
|
||||
+input+ get [ second = ] curry* find drop
|
||||
node@ tuck node-in-d nth node-class ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
#! Depends on node@
|
||||
operand-class class-tag ;
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class< ;
|
||||
|
||||
: phantom-push ( obj -- )
|
||||
1 phantom-d get adjust-phantom
|
||||
phantom-d get push ;
|
||||
|
||||
: phantom-shuffle ( shuffle -- )
|
||||
[ effect-in length phantom-d get phantom-input ] keep
|
||||
shuffle* phantom-d get phantom-append ;
|
||||
|
||||
: phantom->r ( n -- )
|
||||
phantom-d get phantom-input
|
||||
phantom-r get phantom-append ;
|
||||
|
||||
: phantom-r> ( n -- )
|
||||
phantom-r get phantom-input
|
||||
phantom-d get phantom-append ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: inference
|
||||
USING: inference.backend inference.dataflow
|
||||
inference.known-words inference.stack inference.transforms
|
||||
inference.errors sequences prettyprint io effects kernel
|
||||
namespaces quotations ;
|
||||
inference.known-words inference.transforms inference.errors
|
||||
sequences prettyprint io effects kernel namespaces quotations ;
|
||||
|
||||
GENERIC: infer ( quot -- effect )
|
||||
|
||||
|
|
|
|||
|
|
@ -3,14 +3,58 @@
|
|||
IN: inference.known-words
|
||||
USING: alien arrays bit-arrays byte-arrays classes
|
||||
combinators.private continuations.private effects float-arrays
|
||||
generic hashtables hashtables.private
|
||||
inference.backend inference.dataflow io io.backend io.files
|
||||
io.files.private io.streams.c kernel kernel.private math
|
||||
math.private memory namespaces namespaces.private parser
|
||||
prettyprint quotations quotations.private sbufs sbufs.private
|
||||
sequences sequences.private slots.private strings
|
||||
strings.private system threads.private tuples tuples.private
|
||||
vectors vectors.private words ;
|
||||
generic hashtables hashtables.private inference.backend
|
||||
inference.dataflow io io.backend io.files io.files.private
|
||||
io.streams.c kernel kernel.private math math.private memory
|
||||
namespaces namespaces.private parser prettyprint quotations
|
||||
quotations.private sbufs sbufs.private sequences
|
||||
sequences.private slots.private strings strings.private system
|
||||
threads.private tuples tuples.private vectors vectors.private
|
||||
words assocs ;
|
||||
|
||||
! Shuffle words
|
||||
: infer-shuffle-inputs ( shuffle node -- )
|
||||
>r effect-in length 0 r> node-inputs ;
|
||||
|
||||
: shuffle-stacks ( shuffle -- )
|
||||
meta-d [ swap shuffle ] change ;
|
||||
|
||||
: infer-shuffle-outputs ( shuffle node -- )
|
||||
>r effect-out length 0 r> node-outputs ;
|
||||
|
||||
: infer-shuffle ( shuffle -- )
|
||||
dup effect-in ensure-values
|
||||
#shuffle
|
||||
2dup infer-shuffle-inputs
|
||||
over shuffle-stacks
|
||||
2dup infer-shuffle-outputs
|
||||
node, drop ;
|
||||
|
||||
: define-shuffle ( word shuffle -- )
|
||||
[ infer-shuffle ] curry "infer" set-word-prop ;
|
||||
|
||||
{
|
||||
{ drop T{ effect f 1 { } } }
|
||||
{ 2drop T{ effect f 2 { } } }
|
||||
{ 3drop T{ effect f 3 { } } }
|
||||
{ dup T{ effect f 1 { 0 0 } } }
|
||||
{ 2dup T{ effect f 2 { 0 1 0 1 } } }
|
||||
{ 3dup T{ effect f 3 { 0 1 2 0 1 2 } } }
|
||||
{ rot T{ effect f 3 { 1 2 0 } } }
|
||||
{ -rot T{ effect f 3 { 2 0 1 } } }
|
||||
{ dupd T{ effect f 2 { 0 0 1 } } }
|
||||
{ swapd T{ effect f 3 { 1 0 2 } } }
|
||||
{ nip T{ effect f 2 { 1 } } }
|
||||
{ 2nip T{ effect f 3 { 2 } } }
|
||||
{ tuck T{ effect f 2 { 1 0 1 } } }
|
||||
{ over T{ effect f 2 { 0 1 0 } } }
|
||||
{ pick T{ effect f 3 { 0 1 2 0 } } }
|
||||
{ swap T{ effect f 2 { 1 0 } } }
|
||||
} [ define-shuffle ] assoc-each
|
||||
|
||||
\ >r [ infer->r ] "infer" set-word-prop
|
||||
|
||||
\ r> [ infer-r> ] "infer" set-word-prop
|
||||
|
||||
\ declare [
|
||||
1 ensure-values
|
||||
|
|
@ -22,21 +66,6 @@ vectors vectors.private words ;
|
|||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum< make-foldable
|
||||
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum<= make-foldable
|
||||
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum> make-foldable
|
||||
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>= make-foldable
|
||||
|
||||
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ eq? make-foldable
|
||||
|
||||
! Primitive combinators
|
||||
GENERIC: infer-call ( value -- )
|
||||
|
||||
|
|
@ -121,6 +150,21 @@ t over set-effect-terminated?
|
|||
"inferred-effect" set-word-prop
|
||||
|
||||
! Stack effects for all primitives
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum< make-foldable
|
||||
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum<= make-foldable
|
||||
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum> make-foldable
|
||||
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>= make-foldable
|
||||
|
||||
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ eq? make-foldable
|
||||
|
||||
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: inference.stack help.syntax help.markup ;
|
||||
|
||||
HELP: shuffle
|
||||
{ $values { "stack" "a sequence" } { "shuffle" shuffle } { "newstack" "a new sequence" } }
|
||||
{ $description "Applies a stack shuffle pattern to a stack." }
|
||||
{ $errors "Throws an error if the input stack contains insufficient elements." } ;
|
||||
|
||||
HELP: shuffle-stacks
|
||||
{ $values { "shuffle" "an instance of " { $link shuffle } } }
|
||||
{ $description "Applies a stack shuffle pattern to the inference stacks." }
|
||||
{ $errors "Throws an error if the stacks contain insufficient elements." } ;
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: inference.stack
|
||||
USING: inference.dataflow inference.backend arrays generic
|
||||
kernel math namespaces sequences words parser words quotations
|
||||
assocs effects ;
|
||||
|
||||
: split-shuffle ( stack shuffle -- stack1 stack2 )
|
||||
effect-in length swap cut* ;
|
||||
|
||||
: load-shuffle ( stack shuffle -- )
|
||||
effect-in [ set ] 2each ;
|
||||
|
||||
: shuffled-values ( shuffle -- values )
|
||||
effect-out [ get ] map ;
|
||||
|
||||
: shuffle* ( stack shuffle -- newstack )
|
||||
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
|
||||
|
||||
: shuffle ( stack shuffle -- newstack )
|
||||
[ split-shuffle ] keep shuffle* append ;
|
||||
|
||||
: infer-shuffle-inputs ( shuffle node -- )
|
||||
>r effect-in length 0 r> node-inputs ;
|
||||
|
||||
: shuffle-stacks ( shuffle -- )
|
||||
meta-d [ swap shuffle ] change ;
|
||||
|
||||
: infer-shuffle-outputs ( shuffle node -- )
|
||||
>r effect-out length 0 r> node-outputs ;
|
||||
|
||||
: infer-shuffle ( shuffle -- )
|
||||
dup effect-in ensure-values
|
||||
#shuffle
|
||||
2dup infer-shuffle-inputs
|
||||
over shuffle-stacks
|
||||
2dup infer-shuffle-outputs
|
||||
node, drop ;
|
||||
|
||||
: define-shuffle ( word shuffle -- )
|
||||
[ infer-shuffle ] curry "infer" set-word-prop ;
|
||||
|
||||
{
|
||||
{ drop T{ effect f 1 { } } }
|
||||
{ 2drop T{ effect f 2 { } } }
|
||||
{ 3drop T{ effect f 3 { } } }
|
||||
{ dup T{ effect f 1 { 0 0 } } }
|
||||
{ 2dup T{ effect f 2 { 0 1 0 1 } } }
|
||||
{ 3dup T{ effect f 3 { 0 1 2 0 1 2 } } }
|
||||
{ rot T{ effect f 3 { 1 2 0 } } }
|
||||
{ -rot T{ effect f 3 { 2 0 1 } } }
|
||||
{ dupd T{ effect f 2 { 0 0 1 } } }
|
||||
{ swapd T{ effect f 3 { 1 0 2 } } }
|
||||
{ nip T{ effect f 2 { 1 } } }
|
||||
{ 2nip T{ effect f 3 { 2 } } }
|
||||
{ tuck T{ effect f 2 { 1 0 1 } } }
|
||||
{ over T{ effect f 2 { 0 1 0 } } }
|
||||
{ pick T{ effect f 3 { 0 1 2 0 } } }
|
||||
{ swap T{ effect f 2 { 1 0 } } }
|
||||
} [ define-shuffle ] assoc-each
|
||||
|
||||
\ >r [ infer->r ] "infer" set-word-prop
|
||||
|
||||
\ r> [ infer-r> ] "infer" set-word-prop
|
||||
|
|
@ -1 +0,0 @@
|
|||
Stack shuffles as first-class data types
|
||||
Loading…
Reference in New Issue