"y" get "x" get "out" get %fixnum-mod ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
+ ! { +scratch { { 2 "out" } } }
{ +output { "out" } }
} with-template
] "intrinsic" set-word-prop
! See the remark on fixnum-mod for vreg usage
[
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 ,
+ "rem" get "x" get 2array %fixnum/mod ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
- { +output { "quo" "rem" } }
+ ! { +scratch { { 2 "rem" } } }
+ { +output { "x" "rem" } }
} with-template
] "intrinsic" set-word-prop
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
-UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
+: 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 ;
+
+PREDICATE: #call #terminal-call
+ dup node-successor node-successor #terminal?
+ swap if-intrinsic and ;
+
+UNION: #terminal
+ POSTPONE: f #return #values #terminal-merge ;
: tail-call? ( -- ? )
- node-stack get [ node-successor ] map [ #terminal? ] all? ;
+ node-stack get [
+ dup #terminal-call? swap node-successor #terminal? or
+ ] all? ;
GENERIC: linearize* ( node -- next )
dup node-param dup linearize-call-label >r
renamed-label swap node-child linearize-1 r> ;
-: 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 ;
-
: linearize-if ( node label -- next )
<label> [
>r >r node-children first2 linearize-child
! A call stack location.
TUPLE: cs-loc n ;
+UNION: loc ds-loc cs-loc ;
+
TUPLE: phantom-stack height ;
C: phantom-stack ( -- stack )
SYMBOL: phantom-d
SYMBOL: phantom-r
+: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
+
: init-templates ( -- )
<phantom-datastack> phantom-d set
<phantom-callstack> phantom-r set ;
: finalize-heights ( -- )
- phantom-d get finalize-height
- phantom-r get finalize-height ;
+ phantoms [ finalize-height ] 2apply ;
: alloc-reg ( -- n ) free-vregs get pop ;
-: loc? ( obj -- ? ) dup ds-loc? swap cs-loc? or ;
-
: stack>vreg ( vreg# loc -- operand )
>r <vreg> dup r> %peek , ;
2drop
] if ;
-: 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 ;
: ceiling ( x -- y ) neg floor neg ; foldable
-: (repeat) ( i n quot -- )
- pick pick >=
- [ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] if ;
- inline
+G: repeat 1 standard-combination ; inline
-: repeat ( n quot -- | quot: n -- n ) 0 -rot (repeat) ; inline
+: (repeat-fixnum) ( i n quot -- )
+ pick pick fixnum>= [
+ 3drop
+ ] [
+ [ swap >r call 1 fixnum+fast r> ] keep (repeat-fixnum)
+ ] if ; inline
+
+M: fixnum repeat 0 -rot (repeat-fixnum) ;
+
+: (repeat-bignum) ( i n quot -- )
+ pick pick bignum>= [
+ 3drop
+ ] [
+ [ swap >r call 1 bignum+ r> ] keep (repeat-bignum)
+ ] if ; inline
+
+M: bignum repeat 0 -rot (repeat-bignum) ;
: times ( n quot -- | quot: -- )
swap [ >r dup slip r> ] repeat drop ; inline