Code cleanups, fix #if intrinsic linearization, faster repeat combinator

library/compiler/intrinsics.factor

@@ -123,6 +123,7 @@ namespaces sequences words ;
         "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
@@ -131,13 +132,13 @@ namespaces sequences words ;
     ! 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
 

library/compiler/linearizer.factor

@@ -15,10 +15,23 @@ DEFER: #terminal?
 
 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 )
 
@@ -74,12 +87,6 @@ M: #label 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

library/compiler/templates.factor

@@ -12,6 +12,8 @@ TUPLE: ds-loc n ;
 ! A call stack location.
 TUPLE: cs-loc n ;
 
+UNION: loc ds-loc cs-loc ;
+
 TUPLE: phantom-stack height ;
 
 C: phantom-stack ( -- stack )
@@ -75,18 +77,17 @@ M: phantom-stack cut-phantom ( n phantom -- seq )
 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
+    phantoms [ finalize-height ] 2apply ;
-    phantom-r get finalize-height ;
 
 : 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 , ;
 
@@ -125,8 +126,6 @@ SYMBOL: phantom-r
         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 ;

library/math/math.factor

@@ -53,12 +53,25 @@ M: object zero? drop f ;
 
 : ceiling ( x -- y ) neg floor neg ; foldable
 
-: (repeat) ( i n quot -- )
+G: repeat 1 standard-combination ; inline
-    pick pick >=
-    [ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] if ;
-    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