From bdd78ad160b255e2f2cfb3a83e3aca80c6ae9e1a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 03:30:24 +0000
Subject: [PATCH] Generate if-intrinsics in more cases

---
 library/compiler/generator/generator.factor | 45 +++++++++++++++------
 library/compiler/generator/templates.factor |  7 +++-
 library/compiler/ppc/intrinsics.factor      |  3 +-
 3 files changed, 38 insertions(+), 17 deletions(-)

diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 1d3e3a66d8..d52eb6f959 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -12,16 +12,19 @@ M: object stack-reserve* drop 0 ;
 : 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
@@ -108,10 +111,13 @@ M: #label generate-node ( node -- next )
     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 )
@@ -129,19 +135,32 @@ 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 )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 144635146f..f000d491bb 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -211,6 +211,9 @@ SYMBOL: phantom-r
     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 ;
 
@@ -251,7 +254,7 @@ SYMBOL: +clobber
     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
@@ -263,7 +266,7 @@ SYMBOL: +clobber
     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
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 9628ceac3d..9c48ea3844 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -106,11 +106,10 @@ math-internals namespaces sequences words ;
     ! divide x by y, store result in x
     "r" operand "x" operand "y" operand DIVW
     generate-fixnum-mod
-    "x" operand "s" operand MR
 ] H{
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
-    { +output { "x" } }
+    { +output { "s" } }
 } define-intrinsic
 
 \ fixnum-bitnot [