: stack-reserve ( node -- n )
0 swap [ stack-reserve* max ] each-node ;
+: intrinsic ( #call -- quot )
+ node-param "intrinsic" word-prop ;
+
: if-intrinsic ( #call -- quot )
- dup node-successor #if?
- [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+ node-param "if-intrinsic" word-prop ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
PREDICATE: #call #terminal-call
- dup node-successor node-successor #terminal?
+ dup node-successor #if?
+ over node-successor node-successor #terminal? and
swap if-intrinsic and ;
UNION: #terminal
swap node-child generate-word r> ;
! #if
+: end-false-branch ( label -- )
+ tail-call? [ %return drop ] [ %jump-label ] if ;
+
: generate-if ( node label -- next )
<label> [
>r >r node-children first2 generate-nodes
- r> r> %jump-label save-xt generate-nodes
+ r> r> end-false-branch save-xt generate-nodes
] keep save-xt iterate-next ;
M: #if generate-node ( node -- next )
: define-intrinsic ( word quot template -- | quot: -- )
[with-template] "intrinsic" set-word-prop ;
-: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
-
: define-if-intrinsic ( word quot template -- | quot: label -- )
[with-template] "if-intrinsic" set-word-prop ;
-M: #call generate-node ( node -- next )
- dup if-intrinsic [
- >r <label> dup r> call
- >r node-successor r> generate-if node-successor
+: if>boolean-intrinsic ( label -- )
+ <label> "end" set
+ f T{ vreg f 0 } load-literal
+ "end" get %jump-label
+ save-xt
+ t T{ vreg f 0 } load-literal
+ "end" get save-xt
+ T{ vreg f 0 } phantom-d get phantom-push ;
+
+: do-if-intrinsic ( node -- next )
+ [ <label> dup ] keep if-intrinsic call
+ >r node-successor dup #if? [
+ r> generate-if node-successor
] [
- dup intrinsic
- [ call iterate-next ] [ node-param generate-call ] ?if
- ] if* ;
+ drop r> if>boolean-intrinsic iterate-next
+ ] if ;
+
+M: #call generate-node ( node -- next )
+ {
+ { [ dup if-intrinsic ] [ do-if-intrinsic ] }
+ { [ dup intrinsic ] [ intrinsic call iterate-next ] }
+ { [ t ] [ node-param generate-call ] }
+ } cond ;
! #call-label
M: #call-label generate-node ( node -- next )
over length swap cut-phantom
swap phantom-vregs ;
+: phantom-push ( obj stack -- )
+ 1 over adjust-phantom push ;
+
: phantom-append ( seq stack -- )
over length over adjust-phantom swap nappend ;
append ;
: guess-vregs ( -- n )
- +input get dup { } additional-vregs# +scratch get length + ;
+ +input get { } additional-vregs# +scratch get length + ;
: alloc-scratch ( -- )
+scratch get [ alloc-vregs [ <vreg> ] map ] keep
guess-vregs ensure-vregs
! Split the template into available (fast) parts and those
! that require allocating registers and reading the stack
- match-template fast-input
+ +input get match-template fast-input
used-vregs adjust-free-vregs
slow-input
alloc-scratch