namespaces sequences words ;
\ slot [
- H{
- { +input { { f "obj" } { f "n" } } }
- { +output { "obj" } }
- } [
+ [
"obj" get %untag ,
"n" get "obj" get %slot ,
- ] with-template
+ ] H{
+ { +input { { f "obj" } { f "n" } } }
+ { +output { "obj" } }
+ } with-template
] "intrinsic" set-word-prop
\ set-slot [
- H{
- { +input { { f "val" } { f "obj" } { f "slot" } } }
- { +clobber { "obj" } }
- } [
+ [
"obj" get %untag ,
"val" get "obj" get "slot" get %set-slot ,
finalize-contents
"obj" get %write-barrier ,
- ] with-template
+ ] H{
+ { +input { { f "val" } { f "obj" } { f "slot" } } }
+ { +clobber { "obj" } }
+ } with-template
] "intrinsic" set-word-prop
\ char-slot [
- H{
+ [
+ "n" get "str" get %char-slot ,
+ ] H{
{ +input { { f "n" } { f "str" } } }
{ +output { "str" } }
- } [
- "n" get "str" get %char-slot ,
- ] with-template
+ } with-template
] "intrinsic" set-word-prop
\ set-char-slot [
- H{
- { +input { { f "ch" } { f "n" } { f "str" } } }
- } [
+ [
"ch" get "str" get "n" get %set-char-slot ,
- ] with-template
+ ] H{
+ { +input { { f "ch" } { f "n" } { f "str" } } }
+ } with-template
] "intrinsic" set-word-prop
\ type [
- H{
+ [ finalize-contents "in" get %type , ] H{
{ +input { { f "in" } } }
{ +output { "in" } }
- } [ finalize-contents "in" get %type , ] with-template
+ } with-template
] "intrinsic" set-word-prop
\ tag [
- H{
+ [ "in" get %tag , ] H{
{ +input { { f "in" } } }
{ +output { "in" } }
- } [ "in" get %tag , ] with-template
+ } with-template
] "intrinsic" set-word-prop
: binary-op ( op -- )
- H{
+ [
+ finalize-contents >r "y" get "x" get dup r> execute ,
+ ] H{
{ +input { { 0 "x" } { 1 "y" } } }
{ +output { "x" } }
- } [
- finalize-contents >r "y" get "x" get dup r> execute ,
- ] with-template ; inline
+ } with-template ; inline
{
{ fixnum+ %fixnum+ }
] each
: binary-op-fast ( op -- )
- H{
+ [
+ >r "y" get "x" get dup r> execute ,
+ ] H{
{ +input { { f "x" } { f "y" } } }
{ +output { "x" } }
- } [
- >r "y" get "x" get dup r> execute ,
- ] with-template ; inline
+ } with-template ; inline
{
{ fixnum-bitand %fixnum-bitand }
] each
: binary-jump ( label op -- )
- H{
- { +input { { f "x" } { f "y" } } }
- } [
+ [
end-basic-block >r >r "y" get "x" get r> r> execute ,
- ] with-template ; inline
+ ] H{
+ { +input { { f "x" } { f "y" } } }
+ } with-template ; inline
{
{ fixnum<= %jump-fixnum<= }
! 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.
- H{
- { +input { { 0 "x" } { 1 "y" } } }
- { +output { "out" } }
- } [
+ [
finalize-contents
T{ vreg f 2 } "out" set
"y" get "x" get "out" get %fixnum-mod ,
- ] with-template
+ ] H{
+ { +input { { 0 "x" } { 1 "y" } } }
+ { +output { "out" } }
+ } with-template
] "intrinsic" set-word-prop
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
- H{
- { +input { { 0 "x" } { 1 "y" } } }
- { +output { "quo" "rem" } }
- } [
+ [
finalize-contents
T{ vreg f 0 } "quo" set
T{ vreg f 2 } "rem" set
"y" get "x" get 2array
"rem" get "quo" get 2array %fixnum/mod ,
- ] with-template
+ ] H{
+ { +input { { 0 "x" } { 1 "y" } } }
+ { +output { "quo" "rem" } }
+ } with-template
] "intrinsic" set-word-prop
\ fixnum-bitnot [
- H{
+ [ "x" get dup %fixnum-bitnot , ] H{
{ +input { { f "x" } } }
{ +output { "x" } }
- } [ "x" get dup %fixnum-bitnot , ] with-template
+ } with-template
] "intrinsic" set-word-prop
node-param renamed-label linearize-call ;
M: #if linearize* ( node -- next )
- H{
- { +input { { 0 "flag" } } }
- } [
+ [
end-basic-block
<label> dup "flag" get %jump-t ,
- ] with-template linearize-if ;
+ ] H{
+ { +input { { 0 "flag" } } }
+ } with-template linearize-if ;
: dispatch-head ( node -- label/node )
#! Output the jump table insn and return a list of
#! label/branch pairs.
- H{
- { +input { { 0 "n" } } }
- } [ end-basic-block "n" get %dispatch , ] with-template
+ [ end-basic-block "n" get %dispatch , ]
+ H{ { +input { { 0 "n" } } } } with-template
node-children [ <label> dup %target-label , 2array ] map ;
: dispatch-body ( label/node -- )
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: flush-locs ( phantom phantom -- )
- [
- 2dup live-locs \ live-locs set
- [ dup phantom-locs* [ lazy-store ] 2each ] 2apply
- ] with-scope ;
+ 2dup live-locs \ live-locs set
+ [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
: finalize-contents ( -- )
phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
over length over adjust-phantom swap nappend ;
: (template-outputs) ( seq stack -- )
- phantoms swapd phantom-append phantom-append
- compute-free-vregs ;
+ phantoms swapd phantom-append phantom-append ;
SYMBOL: +input
SYMBOL: +output
{ +clobber { } }
} swap hash-union ;
-: adjust-free-vregs ( -- )
- used-vregs free-vregs [ diff ] change ;
+: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
: output-vregs ( -- seq seq )
- +output get +clobber get [ [ get ] map ] 2apply ;
+ +output +clobber [ get [ get ] map ] 2apply ;
: outputs-clash? ( -- ? )
output-vregs append phantoms append
[ swap member? ] contains-with? ;
-: finalize-carefully ( -- )
- #! If the phantom callstack has datastack locations on it,
- #! we cannot rearrange the datastack and expect meaningful
- #! results.
- phantom-r get [ ds-loc? ] contains? [
- finalize-contents
- ] [
- phantom-d get dup { } flush-locs vregs>stack
- ] if ;
-
: slow-input ( template -- )
- dup empty?
- [ finalize-carefully ] unless
- outputs-clash?
- [ finalize-contents ] when
+ dup empty? [ finalize-contents ] unless
+ outputs-clash? [ finalize-contents ] when
phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
+: input-vregs ( -- seq )
+ +input +scratch [ get [ second get vreg-n ] map ] 2apply
+ append ;
+
: template-inputs ( -- )
+input get dup { } additional-vregs# ensure-vregs
- match-template fast-input adjust-free-vregs slow-input ;
+ match-template fast-input
+ used-vregs adjust-free-vregs
+ slow-input
+ input-vregs adjust-free-vregs ;
: template-outputs ( -- )
+output get [ get ] map { } (template-outputs) ;
-: with-template ( spec quot -- )
- swap fix-spec
- [ template-inputs call template-outputs ] bind
+: with-template ( quot spec -- )
+ fix-spec [ template-inputs call template-outputs ] bind
compute-free-vregs ; inline