: 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 ;
: 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
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
{ 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.
] "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
] "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
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 -- )
+ linearize-shuffle iterate-next ;
+
+: linearize-push ( node -- )
compute-free-vregs
- node-shuffle linearize-shuffle
- iterate-next ;
+ >#push< dup length alloc-reg# [ <vreg> ] map
+ [ [ load-literal ] 2each ] keep
+ phantom-d get phantom-append ;
-: ?static-branch ( node -- n )
- node-in-d first dup value?
- [ value-literal 0 1 ? ] [ drop f ] if ;
+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 ;
! 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 ;
: 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
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
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 ;
: %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 -- ? )
>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
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
: 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 )
[ 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 )
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 ;
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
#! 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 { } ;
] 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* ;
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 -- )
! 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
[ 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
: 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
projects / factor.git / commitdiff