Stripping out old compiler code
slava
parent
c6bd0b4aac
commit
25edc7de30
|
|
@ -10,6 +10,7 @@ sequences strings vectors words ;
|
|||
: namespace ( -- namespace ) namestack* peek ; inline
|
||||
: >n ( namespace -- n:namespace ) namestack* push ; inline
|
||||
: n> ( n:namespace -- namespace ) namestack* pop ; inline
|
||||
: ndrop ( n:namespace -- ) namestack* pop* ; inline
|
||||
: global ( -- g ) 4 getenv ; inline
|
||||
: get ( variable -- value ) namestack* hash-stack ; flushable
|
||||
: set ( value variable -- ) namespace set-hash ;
|
||||
|
|
@ -30,13 +31,13 @@ sequences strings vectors words ;
|
|||
|
||||
: dec ( var -- ) -1 swap +@ ; inline
|
||||
|
||||
: bind ( namespace quot -- ) swap >n call n> drop ; inline
|
||||
: bind ( namespace quot -- ) swap >n call ndrop ; inline
|
||||
|
||||
: counter ( var -- n ) global [ dup inc get ] bind ;
|
||||
|
||||
: make-hash ( quot -- hash ) H{ } clone >n call n> ; inline
|
||||
|
||||
: with-scope ( quot -- ) make-hash drop ; inline
|
||||
: with-scope ( quot -- ) H{ } clone >n call ndrop ; inline
|
||||
|
||||
! Building sequences
|
||||
SYMBOL: building
|
||||
|
|
|
|||
|
|
@ -5,122 +5,69 @@ USING: arrays assembler generic hashtables
|
|||
inference kernel kernel-internals lists math math-internals
|
||||
namespaces sequences words ;
|
||||
|
||||
: type-tag ( type -- tag )
|
||||
#! Given a type number, return the tag number.
|
||||
dup 6 > [ drop 3 ] when ;
|
||||
|
||||
: value-tag ( value node -- n/f )
|
||||
#! If the tag is known, output it, otherwise f.
|
||||
node-classes ?hash dup [
|
||||
types [ type-tag ] map dup all-equal?
|
||||
[ first ] [ drop f ] if
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: slot@ ( node -- n/f )
|
||||
#! Compute slot offset.
|
||||
dup node-in-d reverse-slice dup first dup value? [
|
||||
value-literal cells swap second
|
||||
rot value-tag dup [ - ] [ 2drop f ] if
|
||||
] [
|
||||
3drop f
|
||||
] if ;
|
||||
|
||||
\ slot [
|
||||
dup slot@ [
|
||||
{ { 0 "obj" } { value "slot" } } { "obj" } [
|
||||
node %get slot@ "obj" %get %fast-slot ,
|
||||
] with-template
|
||||
] [
|
||||
{ { 0 "obj" } { 1 "n" } } { "obj" } [
|
||||
"obj" %get %untag ,
|
||||
"n" %get "obj" %get %slot ,
|
||||
] with-template
|
||||
] if
|
||||
drop
|
||||
{ { 0 "obj" } { 1 "n" } } { "obj" } [
|
||||
"obj" %get %untag ,
|
||||
"n" %get "obj" %get %slot ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ set-slot [
|
||||
dup slot@ [
|
||||
{ { 0 "val" } { 1 "obj" } { value "slot" } } { } [
|
||||
"val" %get "obj" %get node %get slot@
|
||||
%fast-set-slot ,
|
||||
] with-template
|
||||
] [
|
||||
{ { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
|
||||
"obj" %get %untag ,
|
||||
"val" %get "obj" %get "slot" %get %set-slot ,
|
||||
] with-template
|
||||
] if
|
||||
drop
|
||||
{ { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
|
||||
"obj" %get %untag ,
|
||||
"val" %get "obj" %get "slot" %get %set-slot ,
|
||||
] with-template
|
||||
end-basic-block
|
||||
T{ vreg f 1 } %write-barrier ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ char-slot [
|
||||
drop
|
||||
{ { 0 "n" } { 1 "str" } } { "str" } [
|
||||
"n" %get "str" %get %char-slot ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ set-char-slot [
|
||||
drop
|
||||
{ { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
|
||||
"ch" %get "str" %get "n" %get %set-char-slot ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ type [
|
||||
drop
|
||||
{ { any-reg "in" } } { "in" }
|
||||
[ end-basic-block "in" %get %type , ] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ tag [
|
||||
drop
|
||||
{ { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
{ { value "env" } } { "out" } [
|
||||
T{ vreg f 0 } "out" set
|
||||
"env" %get "out" %get %getenv ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ setenv [
|
||||
{ { any-reg "value" } { value "env" } } { } [
|
||||
"value" %get "env" %get %setenv ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: literal-immediate? ( node -- ? )
|
||||
node-in-d peek dup value?
|
||||
[ value-literal immediate? ] [ drop f ] if ;
|
||||
|
||||
: binary-in ( node -- in )
|
||||
literal-immediate? fixnum-imm? and
|
||||
{ { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ;
|
||||
|
||||
: (binary-op) ( node in -- )
|
||||
{ "x" } [
|
||||
: binary-op ( op -- )
|
||||
{ { 0 "x" } { 1 "y" } } { "x" } [
|
||||
end-basic-block >r "y" %get "x" %get dup r> execute ,
|
||||
] with-template ; inline
|
||||
|
||||
: binary-op ( node op -- )
|
||||
swap dup binary-in (binary-op) ; inline
|
||||
|
||||
: binary-op-reg ( node op -- )
|
||||
swap { { 0 "x" } { 1 "y" } } (binary-op) ; inline
|
||||
|
||||
{
|
||||
{ fixnum+ %fixnum+ }
|
||||
{ fixnum- %fixnum- }
|
||||
{ fixnum-bitand %fixnum-bitand }
|
||||
{ fixnum-bitor %fixnum-bitor }
|
||||
{ fixnum-bitxor %fixnum-bitxor }
|
||||
{ fixnum/i %fixnum/i }
|
||||
{ fixnum* %fixnum* }
|
||||
} [
|
||||
first2 [ binary-op ] curry "intrinsic" set-word-prop
|
||||
first2 [ binary-op drop ] curry
|
||||
"intrinsic" set-word-prop
|
||||
] each
|
||||
|
||||
: binary-jump ( node label op -- )
|
||||
rot { { any-reg "x" } { any-reg "y" } } { } [
|
||||
: binary-jump ( label op -- )
|
||||
{ { any-reg "x" } { any-reg "y" } } { } [
|
||||
end-basic-block >r >r "y" %get "x" %get r> r> execute ,
|
||||
] with-template ; inline
|
||||
|
||||
|
|
@ -131,14 +78,12 @@ namespaces sequences words ;
|
|||
{ fixnum> %jump-fixnum> }
|
||||
{ eq? %jump-eq? }
|
||||
} [
|
||||
first2 [ binary-jump ] curry "if-intrinsic" set-word-prop
|
||||
first2 [ binary-jump drop ] curry
|
||||
"if-intrinsic" set-word-prop
|
||||
] each
|
||||
|
||||
\ fixnum/i [
|
||||
\ %fixnum/i binary-op-reg
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum-mod [
|
||||
drop
|
||||
! This is not clever. Because of x86, %fixnum-mod is
|
||||
! hard-coded to put its output in vreg 2, which happends to
|
||||
! be EDX there.
|
||||
|
|
@ -150,6 +95,7 @@ namespaces sequences words ;
|
|||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum/mod [
|
||||
drop
|
||||
! See the remark on fixnum-mod for vreg usage
|
||||
{ { 0 "x" } { 1 "y" } } { "quo" "rem" } [
|
||||
end-basic-block
|
||||
|
|
@ -161,45 +107,8 @@ namespaces sequences words ;
|
|||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum-bitnot [
|
||||
drop
|
||||
{ { 0 "x" } } { "x" } [
|
||||
"x" %get dup %fixnum-bitnot ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum* [
|
||||
\ %fixnum* binary-op-reg
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
||||
|
||||
: negative-shift ( n node -- )
|
||||
{ { 0 "x" } { value "n" } } { "out" } [
|
||||
dup cell-bits neg <= [
|
||||
drop
|
||||
T{ vreg f 2 } "out" set
|
||||
"x" %get "out" %get %fixnum-sgn ,
|
||||
] [
|
||||
"x" %get "out" set
|
||||
neg "x" %get "out" %get %fixnum>> ,
|
||||
] if
|
||||
] with-template ;
|
||||
|
||||
: fast-shift ( n node -- )
|
||||
over zero? [
|
||||
drop-phantom 2drop
|
||||
] [
|
||||
over 0 < [
|
||||
negative-shift
|
||||
] [
|
||||
2drop slow-shift
|
||||
] if
|
||||
] if ;
|
||||
|
||||
\ fixnum-shift [
|
||||
end-basic-block
|
||||
dup literal-immediate? [
|
||||
[ node-in-d peek value-literal ] keep fast-shift
|
||||
] [
|
||||
drop slow-shift
|
||||
] if
|
||||
] "intrinsic" set-word-prop
|
||||
|
|
|
|||
|
|
@ -102,54 +102,52 @@ SYMBOL: live-d
|
|||
SYMBOL: live-r
|
||||
|
||||
: value-dropped? ( value -- ? )
|
||||
dup value?
|
||||
over live-d get member? not
|
||||
rot live-r get member? not and
|
||||
or ;
|
||||
dup live-d get member? not
|
||||
swap live-r get member? not and ;
|
||||
|
||||
: shuffle-in-template ( values -- value template )
|
||||
[ dup value-dropped? [ drop f ] when ] map
|
||||
dup [ any-reg swap 2array ] map ;
|
||||
: shuffle-in-template ( values -- template )
|
||||
[
|
||||
dup value-dropped? [ drop f ] when any-reg swap 2array
|
||||
] map ;
|
||||
|
||||
: shuffle-out-template ( instack outstack -- stack )
|
||||
#! Avoid storing a value into its former position.
|
||||
dup length [
|
||||
pick ?nth dupd eq? [ <clean> ] when
|
||||
pick ?nth dupd ( eq? ) 2drop f [ <clean> ] when
|
||||
] 2map nip ;
|
||||
|
||||
: linearize-shuffle ( shuffle -- )
|
||||
: linearize-shuffle ( node -- )
|
||||
compute-free-vregs node-shuffle
|
||||
dup shuffle-in-d over shuffle-out-d
|
||||
shuffle-out-template live-d set
|
||||
dup shuffle-in-r over shuffle-out-r
|
||||
shuffle-out-template live-r set
|
||||
dup shuffle-in-d shuffle-in-template
|
||||
rot shuffle-in-r shuffle-in-template template-inputs
|
||||
swap shuffle-in-r shuffle-in-template template-inputs
|
||||
live-d get live-r get template-outputs ;
|
||||
|
||||
M: #shuffle linearize* ( #shuffle -- )
|
||||
compute-free-vregs
|
||||
node-shuffle linearize-shuffle
|
||||
iterate-next ;
|
||||
linearize-shuffle iterate-next ;
|
||||
|
||||
: ?static-branch ( node -- n )
|
||||
node-in-d first dup value?
|
||||
[ value-literal 0 1 ? ] [ drop f ] if ;
|
||||
: linearize-push ( node -- )
|
||||
compute-free-vregs
|
||||
>#push< dup length alloc-reg# [ <vreg> ] map
|
||||
[ [ load-literal ] 2each ] keep
|
||||
phantom-d get phantom-append ;
|
||||
|
||||
M: #push linearize* ( #push -- )
|
||||
linearize-push iterate-next ;
|
||||
|
||||
M: #if linearize* ( node -- next )
|
||||
dup ?static-branch [
|
||||
end-basic-block drop-phantom
|
||||
swap node-children nth linearize-child iterate-next
|
||||
] [
|
||||
dup { { 0 "flag" } } { } [
|
||||
end-basic-block
|
||||
<label> dup "flag" %get %jump-t ,
|
||||
] with-template linearize-if
|
||||
] if* ;
|
||||
{ { 0 "flag" } } { } [
|
||||
end-basic-block
|
||||
<label> dup "flag" %get %jump-t ,
|
||||
] with-template linearize-if ;
|
||||
|
||||
: dispatch-head ( node -- label/node )
|
||||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
dup { { 0 "n" } } { }
|
||||
{ { 0 "n" } } { }
|
||||
[ end-basic-block "n" %get %dispatch , ] with-template
|
||||
node-children [ <label> dup %target-label , 2array ] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler
|
||||
USING: arrays generic inference kernel math
|
||||
namespaces sequences vectors words ;
|
||||
USING: arrays generic inference io kernel math
|
||||
namespaces prettyprint sequences vectors words ;
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n ;
|
||||
|
|
@ -84,17 +84,12 @@ SYMBOL: phantom-r
|
|||
: load-literal ( obj dest -- )
|
||||
over immediate? [ %immediate ] [ %indirect ] if , ;
|
||||
|
||||
G: vreg>stack ( value loc -- ) 1 standard-combination ;
|
||||
|
||||
M: f vreg>stack ( value loc -- ) 2drop ;
|
||||
|
||||
M: value vreg>stack ( value loc -- )
|
||||
>r value-literal r> load-literal ;
|
||||
|
||||
M: object vreg>stack ( value loc -- )
|
||||
%replace , ;
|
||||
|
||||
M: clean vreg>stack ( value loc -- ) 2drop ;
|
||||
: vreg>stack ( value loc -- )
|
||||
{
|
||||
{ [ over not ] [ 2drop ] }
|
||||
{ [ over clean? ] [ 2drop ] }
|
||||
{ [ t ] [ %replace , ] }
|
||||
} cond ;
|
||||
|
||||
: vregs>stack ( phantom -- )
|
||||
dup dup phantom-locs* [ vreg>stack ] 2each
|
||||
|
|
@ -107,20 +102,8 @@ M: clean vreg>stack ( value loc -- ) 2drop ;
|
|||
phantom-d get finalize-phantom
|
||||
phantom-r get finalize-phantom ;
|
||||
|
||||
G: stack>vreg ( value vreg loc -- operand )
|
||||
2 standard-combination ;
|
||||
|
||||
M: f stack>vreg ( value vreg loc -- operand ) 2drop ;
|
||||
|
||||
M: object stack>vreg ( value vreg loc -- operand )
|
||||
>r <vreg> dup r> %peek , nip ;
|
||||
|
||||
M: value stack>vreg ( value vreg loc -- operand )
|
||||
drop dup value eq? [
|
||||
drop
|
||||
] [
|
||||
>r value-literal r> <vreg> [ load-literal ] keep
|
||||
] if ;
|
||||
: stack>vreg ( vreg loc -- operand )
|
||||
over [ >r <vreg> dup r> %peek , ] [ 2drop f ] if ;
|
||||
|
||||
SYMBOL: any-reg
|
||||
|
||||
|
|
@ -143,9 +126,8 @@ SYMBOL: free-vregs
|
|||
dup any-reg eq? [ drop pop ] [ nip ] if
|
||||
] map-with ;
|
||||
|
||||
: (stack>vregs) ( values template locs -- inputs )
|
||||
3array flip
|
||||
[ first3 over [ stack>vreg <clean> ] [ 3drop f ] if ] map ;
|
||||
: alloc-reg# ( n -- regs )
|
||||
free-vregs [ cut ] change ;
|
||||
|
||||
: ?clean ( obj -- obj )
|
||||
dup clean? [ delegate ] when ;
|
||||
|
|
@ -153,26 +135,21 @@ SYMBOL: free-vregs
|
|||
: %get ( obj -- value )
|
||||
get ?clean dup value? [ value-literal ] when ;
|
||||
|
||||
: phantom-vregs ( values template -- )
|
||||
[ second set ] 2each ;
|
||||
: phantom-vregs ( values template -- ) [ second set ] 2each ;
|
||||
|
||||
: stack>vregs ( values phantom template -- values )
|
||||
: stack>vregs ( phantom template -- values )
|
||||
[
|
||||
[ first ] map alloc-regs
|
||||
pick length rot phantom-locs
|
||||
(stack>vregs)
|
||||
dup length rot phantom-locs
|
||||
[ stack>vreg ] 2map
|
||||
] 2keep length neg swap adjust-phantom ;
|
||||
|
||||
: compatible-vreg? ( value vreg -- ? )
|
||||
swap dup value? [ 2drop f ] [ vreg-n = ] if ;
|
||||
|
||||
: compatible-values? ( value template -- ? )
|
||||
>r ?clean r> {
|
||||
{ [ dup not ] [ 2drop t ] }
|
||||
{ [ over not ] [ 2drop f ] }
|
||||
{ [ dup any-reg eq? ] [ drop vreg? ] }
|
||||
{ [ dup integer? ] [ compatible-vreg? ] }
|
||||
{ [ dup value eq? ] [ drop value? ] }
|
||||
{ [ dup any-reg eq? ] [ 2drop t ] }
|
||||
{ [ dup integer? ] [ swap vreg-n = ] }
|
||||
} cond ;
|
||||
|
||||
: template-match? ( template phantom -- ? )
|
||||
|
|
@ -197,13 +174,13 @@ SYMBOL: free-vregs
|
|||
>r dup empty? [ drop ] [ vregs>stack ] if r>
|
||||
swap phantom-vregs ;
|
||||
|
||||
: template-input ( values template phantom -- )
|
||||
: template-input ( template phantom -- )
|
||||
dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
|
||||
|
||||
: template-inputs ( values template values template -- )
|
||||
pick over templates-match? [
|
||||
phantom-r get optimized-input drop
|
||||
phantom-d get optimized-input drop
|
||||
: template-inputs ( template template -- )
|
||||
2dup templates-match? [
|
||||
phantom-r get optimized-input
|
||||
phantom-d get optimized-input
|
||||
] [
|
||||
phantom-r get template-input
|
||||
phantom-d get template-input
|
||||
|
|
@ -213,21 +190,23 @@ SYMBOL: free-vregs
|
|||
end-basic-block -1 phantom-d get adjust-phantom ;
|
||||
|
||||
: prep-output ( value -- value )
|
||||
{
|
||||
{ [ dup value? ] [ ] }
|
||||
{ [ dup clean? ] [ delegate dup value? [ get ] unless ] }
|
||||
{ [ t ] [ get ?clean ] }
|
||||
} cond ;
|
||||
dup clean? [ delegate ] [ get ?clean ] if ;
|
||||
|
||||
: phantom-append ( seq stack -- )
|
||||
over length over adjust-phantom swap nappend ;
|
||||
|
||||
: template-output ( seq stack -- )
|
||||
over length over adjust-phantom
|
||||
swap [ prep-output ] map nappend ;
|
||||
>r [ prep-output ] map r> phantom-append ;
|
||||
|
||||
: trace-outputs ( stack stack -- )
|
||||
"==== Template output:" print [ . ] 2apply ;
|
||||
|
||||
: template-outputs ( stack stack -- )
|
||||
! 2dup trace-outputs
|
||||
phantom-r get template-output
|
||||
phantom-d get template-output ;
|
||||
|
||||
: with-template ( node in out quot -- )
|
||||
compute-free-vregs
|
||||
swap >r >r >r dup node-in-d r> { } { } template-inputs
|
||||
node set r> call r> { } template-outputs ; inline
|
||||
: with-template ( in out quot -- )
|
||||
compute-free-vregs swap >r
|
||||
>r { } template-inputs r> call r> { } template-outputs ;
|
||||
inline
|
||||
|
|
|
|||
|
|
@ -31,8 +31,7 @@ namespaces parser prettyprint sequences strings vectors words ;
|
|||
|
||||
: unbalanced-branches ( in out -- )
|
||||
{ "Unbalanced branches:" } -rot [
|
||||
swap number>string " " rot length number>string
|
||||
append3
|
||||
swap unparse " " rot length unparse append3
|
||||
] 2map append "\n" join inference-error ;
|
||||
|
||||
: unify-effect ( in out -- in out )
|
||||
|
|
|
|||
|
|
@ -122,8 +122,8 @@ M: #call infer-classes* ( node -- )
|
|||
[ over node-out-d intersect-classes ] when*
|
||||
] when drop ;
|
||||
|
||||
M: #shuffle infer-classes* ( node -- )
|
||||
node-out-d [ value? ] subset
|
||||
M: #push infer-classes* ( node -- )
|
||||
node-out-d
|
||||
[ [ value-literal ] keep set-value-literal* ] each ;
|
||||
|
||||
M: #if child-ties ( node -- seq )
|
||||
|
|
|
|||
|
|
@ -53,10 +53,14 @@ TUPLE: #call-label ;
|
|||
C: #call-label make-node ;
|
||||
: #call-label ( label -- node ) param-node <#call-label> ;
|
||||
|
||||
TUPLE: #push ;
|
||||
C: #push make-node ;
|
||||
: #push ( outputs -- node ) d-tail out-node <#push> ;
|
||||
: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
|
||||
|
||||
TUPLE: #shuffle ;
|
||||
C: #shuffle make-node ;
|
||||
: #shuffle ( -- node ) empty-node <#shuffle> ;
|
||||
: #push ( outputs -- node ) d-tail out-node <#shuffle> ;
|
||||
|
||||
TUPLE: #values ;
|
||||
C: #values make-node ;
|
||||
|
|
|
|||
|
|
@ -53,6 +53,10 @@ M: #shuffle literals* ( node -- seq )
|
|||
dup node-out-d swap node-out-r
|
||||
[ [ value? ] subset ] 2apply append ;
|
||||
|
||||
! #push
|
||||
M: #push literals* ( node -- seq )
|
||||
node-values ;
|
||||
|
||||
! #call
|
||||
! M: #call flushable-values* ( node -- )
|
||||
! dup node-param "flushable" word-prop
|
||||
|
|
@ -63,8 +67,9 @@ M: #return live-values* ( node -- seq )
|
|||
#! Values returned by local labels can be killed.
|
||||
dup node-param [ drop { } ] [ delegate live-values* ] if ;
|
||||
|
||||
! nodes that don't use their input values directly
|
||||
UNION: #killable #shuffle #call-label #merge #values #entry ;
|
||||
! nodes that don't use their values directly
|
||||
UNION: #killable
|
||||
#push #shuffle #call-label #merge #values #entry ;
|
||||
|
||||
M: #killable live-values* ( node -- seq ) drop { } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -53,6 +53,10 @@ M: #shuffle optimize-node* ( node -- node/t )
|
|||
] prune-if
|
||||
] if ;
|
||||
|
||||
! #push
|
||||
M: #push optimize-node* ( node -- node/t )
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
|
||||
! #return
|
||||
M: #return optimize-node* ( node -- node/t )
|
||||
node-successor [ node-successor ] [ t ] if* ;
|
||||
|
|
|
|||
|
|
@ -38,6 +38,8 @@ M: comment pprint* ( ann -- )
|
|||
M: #shuffle node>quot ( ? node -- )
|
||||
>r drop t r> dup effect-str "#shuffle: " swap append comment, ;
|
||||
|
||||
M: #push node>quot ( ? node -- ) nip >#push< % ;
|
||||
|
||||
DEFER: dataflow>quot
|
||||
|
||||
: #call>quot ( ? node -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Black box testing of templater optimization
|
||||
|
||||
IN: temporary
|
||||
USING: compiler kernel kernel-internals math-internals test ;
|
||||
USING: arrays compiler kernel kernel-internals math
|
||||
math-internals namespaces test ;
|
||||
|
||||
! Oops!
|
||||
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
|
||||
|
|
@ -27,3 +28,41 @@ unit-test
|
|||
[ 1 2 2 ]
|
||||
[ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
|
||||
unit-test
|
||||
|
||||
: jxyz
|
||||
over bignum? [
|
||||
dup ratio? [
|
||||
[ >fraction ] 2apply swapd
|
||||
>r 2array swap r> 2array swap
|
||||
] when
|
||||
] when ;
|
||||
|
||||
\ jxyz compile
|
||||
|
||||
[ { 1 2 } { 1 1 } ] [ 1 >bignum 1/2 jxyz ] unit-test
|
||||
|
||||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] bind
|
||||
\ foo [ global >n get n> drop ] compile-1
|
||||
] unit-test
|
||||
|
||||
: blech drop ;
|
||||
|
||||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] bind
|
||||
\ foo [ global [ get ] swap blech call ] compile-1
|
||||
] unit-test
|
||||
|
||||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] bind
|
||||
\ foo [ global [ get ] swap >n call n> drop ] compile-1
|
||||
] unit-test
|
||||
|
||||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] bind
|
||||
\ foo [ global [ get ] bind ] compile-1
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -225,6 +225,14 @@ DEFER: do-crap
|
|||
: do-crap dup [ do-crap ] [ more-crap ] if ;
|
||||
[ [ do-crap ] infer ] unit-test-fails
|
||||
|
||||
! Error reporting is wrong
|
||||
G: xyz math-combination ;
|
||||
M: fixnum xyz 2array ;
|
||||
M: ratio xyz
|
||||
[ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
|
||||
|
||||
[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
|
||||
|
||||
[ { 2 1 } ] [ [ swons ] infer ] unit-test
|
||||
[ { 1 2 } ] [ [ uncons ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ unit ] infer ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue