From f684243e2f6b352ab6da054de6906592f0e14b44 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 21:13:02 +0000
Subject: [PATCH] Got scratch registers working; PowerPC backend fully
 operational, x86 in progress

---
 TODO.FACTOR.txt                             |   5 +-
 library/compiler/generator/generator.factor |   8 +-
 library/compiler/generator/templates.factor |  56 ++-
 library/compiler/intrinsics.factor          | 150 --------
 library/compiler/ppc/architecture.factor    |  17 +-
 library/compiler/ppc/intrinsics.factor      | 364 ++++++++++++--------
 library/compiler/x86/architecture.factor    |  17 +-
 7 files changed, 280 insertions(+), 337 deletions(-)
 delete mode 100644 library/compiler/intrinsics.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 6edf8eba78..1df68b8ece 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,8 +1,8 @@
 should fix in 0.82:
 
+- type inference busted for tuple constructors
 - constant branch folding
-- getenv, setenv, fast-slot stuff
-- more flexible fixnum intrinsics
+- fast-slot stuff
 - compile if-intrinsic even if there is no #if there
 - 3 >n fep
 - amd64 %box-struct
@@ -13,7 +13,6 @@ should fix in 0.82:
 - speed up ideas:
   - only do clipping for certain gadgets
   - use glRect
-- cocoa: global menu bar with useful commands
 
 + portability:
 
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 98616c2b08..1d3e3a66d8 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -117,7 +117,7 @@ M: #label generate-node ( node -- next )
 M: #if generate-node ( node -- next )
     [
         end-basic-block
-        <label> dup "flag" get %jump-t
+        <label> dup %jump-t
     ] H{
         { +input { { 0 "flag" } } }
     } with-template generate-if ;
@@ -153,8 +153,10 @@ M: #call-label generate-node ( node -- next )
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    [ end-basic-block "n" get %dispatch ]
-    H{ { +input { { 0 "n" } } } } with-template
+    [ end-basic-block %dispatch ] H{
+        { +input { { f "n" } } }
+        { +scratch { { f "scratch" } } }
+    } with-template
     node-children [ <label> dup target-label 2array ] map ;
 
 : dispatch-body ( label/node -- )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 1c934b7bf9..144635146f 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -4,8 +4,27 @@ IN: compiler
 USING: arrays generic hashtables inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
+! Register allocation
 SYMBOL: free-vregs
 
+: alloc-reg ( -- n )
+    free-vregs get pop ;
+
+: alloc-reg# ( n -- regs )
+    free-vregs [ cut ] change ;
+
+: requested-vregs ( template -- n )
+    0 [ [ 1+ ] unless ] reduce ;
+
+: template-vreg# ( template template -- n )
+    [ requested-vregs ] 2apply + ;
+
+: alloc-vregs ( template -- template )
+    [ first [ alloc-reg ] unless* ] map ;
+
+: adjust-free-vregs ( seq -- )
+    free-vregs [ diff ] change ;
+
 ! A data stack location.
 TUPLE: ds-loc n ;
 
@@ -86,8 +105,6 @@ SYMBOL: phantom-r
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
-: alloc-reg ( -- n ) free-vregs get pop ;
-
 : stack>vreg ( vreg# loc -- operand )
     >r <vreg> dup r> %peek ;
 
@@ -143,18 +160,6 @@ SYMBOL: phantom-r
     used-vregs vregs length reverse diff
     >vector free-vregs set ;
 
-: requested-vregs ( template -- n )
-    0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
-    [ requested-vregs ] 2apply + ;
-
-: alloc-regs ( template -- template )
-    [ [ alloc-reg ] unless* ] map ;
-
-: alloc-reg# ( n -- regs )
-    free-vregs [ cut ] change ;
-
 : additional-vregs# ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
     0 [ 0 max + ] reduce ;
@@ -176,8 +181,7 @@ SYMBOL: phantom-r
 
 : stack>vregs ( phantom template -- values )
     [
-        [ first ] map alloc-regs
-        dup length rot phantom-locs
+        alloc-vregs dup length rot phantom-locs
         [ stack>vreg ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
@@ -226,8 +230,6 @@ SYMBOL: +clobber
         { +clobber { } }
     } swap hash-union ;
 
-: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
-
 : output-vregs ( -- seq seq )
     +output +clobber [ get [ get ] map ] 2apply ;
 
@@ -236,7 +238,11 @@ SYMBOL: +clobber
     [ swap member? ] contains-with? ;
 
 : slow-input ( template -- )
+    ! Are we loading stuff from the stack? Then flush out
+    ! remaining vregs, not slurped in by fast-input.
     dup empty? [ finalize-contents ] unless
+    ! Do the outputs clash with vregs on the phantom stacks?
+    ! Then we must flush them first.
     outputs-clash? [ finalize-contents ] when
     phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
@@ -244,11 +250,23 @@ SYMBOL: +clobber
     +input +scratch [ get [ second get vreg-n ] map ] 2apply
     append ;
 
+: guess-vregs ( -- n )
+    +input get dup { } additional-vregs# +scratch get length + ;
+
+: alloc-scratch ( -- )
+    +scratch get [ alloc-vregs [ <vreg> ] map ] keep
+    phantom-vregs ;
+
 : template-inputs ( -- )
-    +input get dup { } additional-vregs# ensure-vregs
+    ! Ensure we have enough to hold any new stack elements we
+    ! will read (if any), and scratch.
+    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
     used-vregs adjust-free-vregs
     slow-input
+    alloc-scratch
     input-vregs adjust-free-vregs ;
 
 : template-outputs ( -- )
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
deleted file mode 100644
index 1f53b6d535..0000000000
--- a/library/compiler/intrinsics.factor
+++ /dev/null
@@ -1,150 +0,0 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays assembler generic hashtables
-inference kernel kernel-internals lists math math-internals
-namespaces sequences words ;
-
-\ slot [
-    [
-        "obj" get %untag ,
-        "n" get "obj" get %slot ,
-    ] H{
-        { +input { { f "obj" } { f "n" } } }
-        { +output { "obj" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ set-slot [
-    [
-        "obj" get %untag ,
-        "val" get "obj" get "slot" get %set-slot ,
-        finalize-contents
-        "obj" get %write-barrier ,
-    ] H{
-        { +input { { f "val" } { f "obj" } { f "slot" } } }
-        { +clobber { "obj" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ char-slot [
-    [
-        "n" get "str" get %char-slot ,
-    ] H{
-        { +input { { f "n" } { f "str" } } }
-        { +output { "str" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ set-char-slot [
-    [
-        "ch" get "str" get "n" get %set-char-slot ,
-    ] H{
-        { +input { { f "ch" } { f "n" } { f "str" } } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ type [
-    [ finalize-contents "in" get %type , ] H{
-        { +input { { f "in" } } }
-        { +output { "in" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ tag [
-    [ "in" get %tag , ] H{
-        { +input { { f "in" } } }
-        { +output { "in" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-: binary-op ( op -- )
-    [
-        finalize-contents >r "y" get "x" get dup r> execute ,
-    ] H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "x" } }
-    } with-template ; inline
-
-{
-    { fixnum+       %fixnum+       }
-    { fixnum-       %fixnum-       }
-    { fixnum/i      %fixnum/i      }
-    { fixnum*       %fixnum*       }
-} [
-    first2 [ binary-op ] curry
-    "intrinsic" set-word-prop
-] each
-
-: binary-op-fast ( op -- )
-    [
-        >r "y" get "x" get dup r> execute ,
-    ] H{
-        { +input { { f "x" } { f "y" } } }
-        { +output { "x" } }
-    } with-template ; inline
-
-{
-    { fixnum-bitand %fixnum-bitand }
-    { fixnum-bitor  %fixnum-bitor  }
-    { fixnum-bitxor %fixnum-bitxor }
-    { fixnum+fast   %fixnum+fast   }
-    { fixnum-fast   %fixnum-fast   }
-} [
-    first2 [ binary-op-fast ] curry
-    "intrinsic" set-word-prop
-] each
-
-: binary-jump ( label op -- )
-    [
-        end-basic-block >r >r "y" get "x" get r> r> execute ,
-    ] H{
-        { +input { { f "x" } { f "y" } } }
-    } with-template ; inline
-
-{
-    { fixnum<= %jump-fixnum<= }
-    { fixnum<  %jump-fixnum<  }
-    { fixnum>= %jump-fixnum>= }
-    { fixnum>  %jump-fixnum>  }
-    { eq?      %jump-eq?      }
-} [
-    first2 [ binary-jump ] curry
-    "if-intrinsic" set-word-prop
-] each
-
-\ fixnum-mod [
-    ! 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.
-    [
-        finalize-contents
-        T{ vreg f 2 } "out" set
-        "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
-
-\ fixnum/mod [
-    ! See the remark on fixnum-mod for vreg usage
-    [
-        finalize-contents
-        T{ vreg f 2 } "rem" set
-        "y" get "x" get 2array
-        "rem" get "x" get 2array %fixnum/mod ,
-    ] H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        ! { +scratch { { 2 "rem" } } }
-        { +output { "x" "rem" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ fixnum-bitnot [
-    [ "x" get dup %fixnum-bitnot , ] H{
-        { +input { { f "x" } } }
-        { +output { "x" } }
-    } with-template
-] "intrinsic" set-word-prop
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 69e2129627..3c8b729419 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -69,17 +69,18 @@ M: object load-literal ( literal vreg -- )
 : %jump ( label -- )
     %epilogue dup postpone-word %jump-label ;
 
-: %jump-t ( label vreg -- )
-    0 swap v>operand f address CMPI BNE ;
+: %jump-t ( label -- )
+    0 "flag" operand f address CMPI BNE ;
 
-: %dispatch ( vreg -- )
-    v>operand dup dup 1 SRAWI
+: %dispatch ( -- )
+    "n" operand dup 1 SRAWI
     ! The value 24 is a magic number. It is the length of the
     ! instruction sequence that follows to be generated.
-    compiled-offset 24 + 11 LOAD32  rel-2/2 rel-address
-    dup dup 11 ADD
-    dup dup 0 LWZ
-    MTLR
+    compiled-offset 24 + "scratch" operand LOAD32
+    rel-2/2 rel-address
+    "n" operand dup "scratch" operand ADD
+    "n" operand dup 0 LWZ
+    "n" operand MTLR
     BLR ;
 
 : %return ( -- ) %epilogue BLR ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 50a8971688..85cace3560 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: assembler kernel kernel-internals math math-internals
-namespaces sequences ;
+USING: alien assembler kernel kernel-internals math
+math-internals namespaces sequences words ;
 
 : untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
 
@@ -11,11 +11,12 @@ namespaces sequences ;
 : untag-fixnum ( src dest -- ) tag-bits SRAWI ;
 
 \ tag [
-    "in" operand dup tag-mask ANDI
-    "in" operand dup tag-fixnum
+    "in" operand "out" operand tag-mask ANDI
+    "out" operand dup tag-fixnum
 ] H{
     { +input { { f "in" } } }
-    { +output { "in" } }
+    { +scratch { { f "out" } } }
+    { +output { "out" } }
 } define-intrinsic
 
 : generate-slot ( size quot -- )
@@ -43,6 +44,42 @@ namespaces sequences ;
     { +output { "obj" } }
 } define-intrinsic
 
+: generate-set-slot ( size quot -- )
+    >r >r
+    ! turn tagged fixnum slot # into an offset, multiple of 4
+    "slot" operand dup tag-bits r> - SRAWI
+    ! compute slot address in 1st input
+    "slot" operand dup "obj" operand ADD
+    ! store new slot value
+    "val" operand "slot" operand r> call ; inline
+
+: generate-write-barrier ( -- )
+    #! Mark the card pointed to by vreg.
+    "obj" operand dup card-bits SRAWI
+    "obj" operand dup 16 ADD
+    "x" operand "obj" operand 0 LBZ
+    "x" operand dup card-mark ORI
+    "x" operand "obj" operand 0 STB ;
+
+\ set-slot [
+    "obj" operand dup untag
+    cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
+] H{
+    { +input { { f "val" } { f "obj" } { f "slot" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
+
+\ set-char-slot [
+    ! untag the new value in 0th input
+    "val" operand dup untag-fixnum
+    1 [ string-offset STH ] generate-set-slot
+] H{
+    { +input { { f "val" } { f "slot" } { f "obj" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
+
 : define-binary-op ( word op -- )
     [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
         { +input { { f "x" } { f "y" } } }
@@ -59,6 +96,23 @@ namespaces sequences ;
     first2 define-binary-op
 ] each
 
+: generate-fixnum-mod
+    #! PowerPC doesn't have a MOD instruction; so we compute
+    #! x-(x/y)*y. Puts the result in "s" operand.
+    "s" operand "r" operand "y" operand MULLW
+    "s" operand "s" operand "x" operand SUBF ;
+
+\ fixnum-mod [
+    ! 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" } }
+} define-intrinsic
+
 \ fixnum-bitnot [
     "x" operand dup NOT
     "x" operand dup untag
@@ -83,143 +137,163 @@ namespaces sequences ;
     first2 define-binary-jump
 ] each
 
-! M: %type generate-node ( vop -- )
-!     drop
-!     <label> "f" set
-!     <label> "end" set
-!     ! Get the tag
-!     0 input-operand 1 scratch tag-mask ANDI
-!     ! Tag the tag
-!     1 scratch 0 scratch tag-fixnum
-!     ! Compare with object tag number (3).
-!     0 1 scratch object-tag CMPI
-!     ! Jump if the object doesn't store type info in its header
-!     "end" get BNE
-!     ! It does store type info in its header
-!     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-!     0 0 input-operand object-tag CMPI
-!     "f" get BEQ
-!     ! The pointer is not equal to 3. Load the object header.
-!     0 scratch 0 input-operand object-tag neg LWZ
-!     0 scratch dup untag
-!     "end" get B
-!     "f" get save-xt
-!     ! The pointer is equal to 3. Load F_TYPE (9).
-!     f type tag-bits shift 0 scratch LI
-!     "end" get save-xt
-!     0 output-operand 0 scratch MR ;
-! 
-! : generate-set-slot ( size quot -- )
-!     >r >r
-!     ! turn tagged fixnum slot # into an offset, multiple of 4
-!     2 input-operand dup tag-bits r> - SRAWI
-!     ! compute slot address in 1st input
-!     2 input-operand dup 1 input-operand ADD
-!     ! store new slot value
-!     0 input-operand 2 input-operand r> call ; inline
-! 
-! M: %set-slot generate-node ( vop -- )
-!     drop cell log2 [ 0 STW ] generate-set-slot ;
-! 
-! M: %write-barrier generate-node ( vop -- )
-!     #! Mark the card pointed to by vreg.
-!     drop
-!     0 input-operand dup card-bits SRAWI
-!     0 input-operand dup 16 ADD
-!     0 scratch 0 input-operand 0 LBZ
-!     0 scratch dup card-mark ORI
-!     0 scratch 0 input-operand 0 STB ;
-! 
-! : simple-overflow ( inv word -- )
-!     >r >r
-!     <label> "end" set
-!     "end" get BNO
-!     >3-vop< r> execute
-!     0 input-operand dup untag-fixnum
-!     1 input-operand dup untag-fixnum
-!     >3-vop< r> execute
-!     "s48_long_to_bignum" f compile-c-call
-!     ! An untagged pointer to the bignum is now in r3; tag it
-!     0 output-operand dup bignum-tag ORI
-!     "end" get save-xt ; inline
-! 
-! M: %fixnum+ generate-node ( vop -- )
-!     drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
-! 
-! M: %fixnum- generate-node ( vop -- )
-!     drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
-! 
-! M: %fixnum* generate-node ( vop -- )
-!     #! Note that this assumes the output will be in r3.
-!     drop
-!     <label> "end" set
-!     1 input-operand dup untag-fixnum
-!     0 MTXER
-!     0 scratch 0 input-operand 1 input-operand MULLWO.
-!     "end" get BNO
-!     1 scratch 0 input-operand 1 input-operand MULHW
-!     4 1 scratch MR
-!     3 0 scratch MR
-!     "s48_fixnum_pair_to_bignum" f compile-c-call
-!     ! now we have to shift it by three bits to remove the second
-!     ! tag
-!     tag-bits neg 4 LI
-!     "s48_bignum_arithmetic_shift" f compile-c-call
-!     ! An untagged pointer to the bignum is now in r3; tag it
-!     0 output-operand 0 scratch bignum-tag ORI
-!     "end" get save-xt
-!     0 output-operand 0 scratch MR ;
-! 
-! : generate-fixnum/i
-!     #! This VOP is funny. If there is an overflow, it falls
-!     #! through to the end, and the result is in 0 output-operand.
-!     #! Otherwise it jumps to the "no-overflow" label and the
-!     #! result is in 0 scratch.
-!     0 scratch 1 input-operand 0 input-operand DIVW
-!     ! if the result is greater than the most positive fixnum,
-!     ! which can only ever happen if we do
-!     ! most-negative-fixnum -1 /i, then the result is a bignum.
-!     <label> "end" set
-!     <label> "no-overflow" set
-!     most-positive-fixnum 1 scratch LOAD
-!     0 scratch 0 1 scratch CMP
-!     "no-overflow" get BLE
-!     most-negative-fixnum neg 3 LOAD
-!     "s48_long_to_bignum" f compile-c-call
-!     3 dup bignum-tag ORI ;
-! 
-! M: %fixnum/i generate-node ( vop -- )
-!     #! This has specific vreg requirements.
-!     drop
-!     generate-fixnum/i
-!     "end" get B
-!     "no-overflow" get save-xt
-!     0 scratch 0 output-operand tag-fixnum
-!     "end" get save-xt ;
-! 
-! : generate-fixnum-mod
-!     #! PowerPC doesn't have a MOD instruction; so we compute
-!     #! x-(x/y)*y. Puts the result in 1 scratch.
-!     1 scratch 0 scratch 0 input-operand MULLW
-!     1 scratch 1 scratch 1 input-operand SUBF ;
-! 
-! M: %fixnum-mod generate-node ( vop -- )
-!     drop
-!     ! divide in2 by in1, store result in out1
-!     0 scratch 1 input-operand 0 input-operand DIVW
-!     generate-fixnum-mod
-!     0 output-operand 1 scratch MR ;
-! 
-! M: %fixnum/mod generate-node ( vop -- )
-!     #! This has specific vreg requirements. Note: if there's an
-!     #! overflow, (most-negative-fixnum 1 /mod) the modulus is
-!     #! always zero.
-!     drop
-!     generate-fixnum/i
-!     0 0 output-operand LI
-!     "end" get B
-!     "no-overflow" get save-xt
-!     generate-fixnum-mod
-!     0 scratch 1 output-operand tag-fixnum
-!     0 output-operand 1 scratch MR
-!     "end" get save-xt ;
+\ type [
+    <label> "f" set
+    <label> "end" set
+    ! Get the tag
+    "obj" operand "y" operand tag-mask ANDI
+    ! Tag the tag
+    "y" operand "x" operand tag-fixnum
+    ! Compare with object tag number (3).
+    0 "y" operand object-tag CMPI
+    ! Jump if the object doesn't store type info in its header
+    "end" get BNE
+    ! It does store type info in its header
+    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+    0 "obj" operand object-tag CMPI
+    "f" get BEQ
+    ! The pointer is not equal to 3. Load the object header.
+    "x" operand "obj" operand object-tag neg LWZ
+    "x" operand dup untag
+    "end" get B
+    "f" get save-xt
+    ! The pointer is equal to 3. Load F_TYPE (9).
+    f type tag-bits shift "x" operand LI
+    "end" get save-xt
+] H{
+    { +input { { f "obj" } } }
+    { +scratch { { f "x" } { f "y" } } }
+    { +output { "x" } }
+} define-intrinsic
+
+: simple-overflow ( word -- )
+    >r
+    <label> "end" set
+    "end" get BNO
+    { "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
+    3 "y" operand "x" operand r> execute
+    "s48_long_to_bignum" f %alien-invoke
+    ! An untagged pointer to the bignum is now in r3; tag it
+    3 "r" operand bignum-tag ORI
+    "end" get save-xt ; inline
+
+\ fixnum+ [
+    finalize-contents
+    0 MTXER
+    "r" operand "y" operand "x" operand ADDO.
+    \ ADD simple-overflow
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } } }
+    { +output { "r" } }
+} define-intrinsic
+
+\ fixnum- [
+    finalize-contents
+    0 MTXER
+    "r" operand "y" operand "x" operand SUBFO.
+    \ SUBF simple-overflow
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } } }
+    { +output { "r" } }
+} define-intrinsic
+
+: ?MR 2dup = [ 2drop ] [ MR ] if ;
+
+\ fixnum* [
+    finalize-contents
+    <label> "end" set
+    "r" operand "x" operand untag-fixnum
+    0 MTXER
+    11 "y" operand "r" operand MULLWO.
+    "end" get BNO
+    4 "y" operand "r" operand MULHW
+    3 11 ?MR
+    "s48_fixnum_pair_to_bignum" f %alien-invoke
+    ! now we have to shift it by three bits to remove the second
+    ! tag
+    tag-bits neg 4 LI
+    "s48_bignum_arithmetic_shift" f %alien-invoke
+    ! An untagged pointer to the bignum is now in r3; tag it
+    3 11 bignum-tag ORI
+    "end" get save-xt
+    "s" operand 11 MR
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "s" } }
+} define-intrinsic
+
+: generate-fixnum/i
+    #! This VOP is funny. If there is an overflow, it falls
+    #! through to the end, and the result is in "x" operand.
+    #! Otherwise it jumps to the "no-overflow" label and the
+    #! result is in "r" operand.
+    <label> "end" set
+    <label> "no-overflow" set
+    "r" operand "x" operand "y" operand DIVW
+    ! if the result is greater than the most positive fixnum,
+    ! which can only ever happen if we do
+    ! most-negative-fixnum -1 /i, then the result is a bignum.
+    most-positive-fixnum "s" operand LOAD
+    "r" operand 0 "s" operand CMP
+    "no-overflow" get BLE
+    most-negative-fixnum neg 3 LOAD
+    "s48_long_to_bignum" f %alien-invoke
+    "x" operand 3 bignum-tag ORI ;
+
+\ fixnum/i [
+    finalize-contents
+    generate-fixnum/i
+    "end" get B
+    "no-overflow" get save-xt
+    "r" operand "x" operand tag-fixnum
+    "end" get save-xt
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "x" } }
+} define-intrinsic
+
+\ fixnum/mod [
+    finalize-contents
+    generate-fixnum/i
+    0 "s" operand LI
+    "end" get B
+    "no-overflow" get save-xt
+    generate-fixnum-mod
+    "r" operand "x" operand tag-fixnum
+    "end" get save-xt
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "x" "s" } }
+} define-intrinsic
+
+: userenv ( reg -- )
+    #! Load the userenv pointer in a register.
+    "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
+
+\ getenv [
+    "n" operand dup 1 SRAWI
+    "x" operand userenv
+    "x" operand "n" operand "x" operand ADD
+    "x" operand dup 0 LWZ
+] H{
+    { +input { { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +output { "x" } }
+    { +clobber { "n" } }
+} define-intrinsic
+
+\ setenv [
+    "n" operand dup 1 SRAWI
+    "x" operand userenv
+    "x" operand "n" operand "x" operand ADD
+    "val" operand "x" operand 0 STW
+] H{
+    { +input { { f "val" } { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "n" } }
+} define-intrinsic
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index e32282ede7..112f18e09d 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: alien arrays assembler generic kernel kernel-internals
-math sequences words ;
+math namespaces sequences words ;
 
 ! x86 register assignments
 ! EAX, ECX, EDX vregs
@@ -59,24 +59,23 @@ M: object load-literal ( dest literal -- )
 
 : %jump-label ( label -- ) JMP ;
 
-: %jump-t ( label vreg -- )
-    v>operand f v>operand CMP JNE ;
+: %jump-t ( label -- )
+    "flag" operand f v>operand CMP JNE ;
 
-: %dispatch ( vreg -- )
+: %dispatch ( -- )
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.
-    drop
     <label> "end" set
     ! Untag and multiply to get a jump table offset
-    dup fixnum>slot@
+    "n" operand fixnum>slot@
     ! Add to jump table base. We use a temporary register since
     ! on AMD4 we have to load a 64-bit immediate. On x86, this
     ! is redundant.
-    0 scratch HEX: ffffffff MOV "end" get absolute-cell
-    dup 0 scratch ADD
+    "scratch" get HEX: ffffffff MOV "end" get absolute-cell
+    "n" operand "scratch" get ADD
     ! Jump to jump table entry
-    dup [] JMP
+    "n" operand [] JMP
     ! Align for better performance
     compile-aligned
     ! Fix up jump table pointer