From 2517b2fc2bcb85e469d30500c524bfe58fdaf9fb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 21:42:19 -0500
Subject: [PATCH] compiler: combine ##load-constant followed by ##alien-double
 into a ##load-double on x86-32, saving an integer register

---
 basis/bootstrap/compiler/compiler.factor      |   2 +-
 .../cfg/instructions/instructions.factor      |   4 +
 .../preferred/preferred.factor                |  14 +-
 .../representations-tests.factor              | 116 +++++++++++++-
 .../representations/representations.factor    | 151 +++++++++++-------
 basis/compiler/codegen/codegen.factor         |   1 +
 basis/compiler/codegen/fixup/fixup.factor     |   5 +-
 basis/compiler/constants/constants.factor     |   3 +-
 .../recursive/recursive-tests.factor          |   2 +-
 basis/cpu/architecture/architecture.factor    |   8 +-
 basis/cpu/ppc/ppc.factor                      |   2 +-
 basis/cpu/x86/32/32.factor                    |  11 +-
 basis/cpu/x86/x86.factor                      |   6 +-
 vm/code_blocks.cpp                            |   3 +
 vm/compaction.cpp                             |   3 +
 vm/image.cpp                                  |   3 +
 vm/instruction_operands.cpp                   |  15 ++
 vm/instruction_operands.hpp                   |   7 +
 vm/layouts.hpp                                |   2 +
 vm/slot_visitor.hpp                           |  11 +-
 20 files changed, 290 insertions(+), 79 deletions(-)

diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index 0237ed99ee..90562e9fc7 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -57,7 +57,7 @@ gc
 
         curry compose uncurry
 
-        array-nth set-array-nth length>>
+        array-nth set-array-nth
 
         wrap probe
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index c015cb640b..5ddf7b4db5 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -33,6 +33,10 @@ INSN: ##load-constant
 def: dst/int-rep
 constant: obj ;
 
+INSN: ##load-double
+def: dst/double-rep
+constant: val ;
+
 INSN: ##peek
 def: dst/int-rep
 literal: loc ;
diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor
index ffb8f9a390..e4114c9249 100644
--- a/basis/compiler/cfg/representations/preferred/preferred.factor
+++ b/basis/compiler/cfg/representations/preferred/preferred.factor
@@ -68,23 +68,23 @@ PRIVATE>
     tri
 ] with-compilation-unit
 
-: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
 
-: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
 
-: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
 
+: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
+
 : with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
     '[
         [ basic-block set ] [
             [
-                _
-                [ each-def-rep ]
-                [ each-use-rep ]
-                [ each-temp-rep ] 2tri
+                _ each-rep
             ] each-non-phi
         ] bi
     ] each-basic-block ; inline
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index c50cfc4c86..a00f65e075 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -1,6 +1,7 @@
-USING: tools.test cpu.architecture
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.representations.preferred ;
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.representations.preferred cpu.architecture kernel
+namespaces tools.test sequences arrays system ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -16,4 +17,111 @@ IN: compiler.cfg.representations
        { dst 5 }
        { src 3 }
     } defs-vreg-rep
-] unit-test
\ No newline at end of file
+] unit-test
+
+: test-representations ( -- )
+    cfg new 0 get >>entry dup cfg set select-representations drop ;
+
+! Make sure cost calculation isn't completely wrong
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##peek f 2 D 1 }
+    T{ ##add-float f 3 1 2 }
+    T{ ##replace f 3 D 0 }
+    T{ ##replace f 3 D 1 }
+    T{ ##replace f 3 D 2 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
+
+cpu x86.32? [
+
+    ! Make sure load-constant is converted into load-double
+    V{
+        T{ ##prologue }
+        T{ ##branch }
+    } 0 test-bb
+
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##load-constant f 2 0.5 }
+        T{ ##add-float f 3 1 2 }
+        T{ ##replace f 3 D 0 }
+        T{ ##branch }
+    } 1 test-bb
+
+    V{
+        T{ ##epilogue }
+        T{ ##return }
+    } 2 test-bb
+
+    0 1 edge
+    1 2 edge
+
+    [ ] [ test-representations ] unit-test
+
+    [ t ] [ 1 get instructions>> second ##load-double? ] unit-test
+
+    ! Make sure phi nodes are handled in a sane way
+    V{
+        T{ ##prologue }
+        T{ ##branch }
+    } 0 test-bb
+
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##compare-imm-branch f 1 2 }
+    } 1 test-bb
+
+    V{
+        T{ ##load-constant f 2 1.5 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{
+        T{ ##load-constant f 3 2.5 }
+        T{ ##branch }
+    } 3 test-bb
+
+    V{
+        T{ ##phi f 4 }
+        T{ ##peek f 5 D 0 }
+        T{ ##add-float f 6 4 5 }
+        T{ ##replace f 6 D 0 }
+    } 4 test-bb
+
+    V{
+        T{ ##epilogue }
+        T{ ##return }
+    } 5 test-bb
+
+    test-diamond
+    4 5 edge
+
+    2 get 2 2array
+    3 get 3 2array 2array 4 get instructions>> first (>>inputs)
+
+    [ ] [ test-representations ] unit-test
+
+    [ t ] [ 2 get instructions>> first ##load-double? ] unit-test
+
+    [ t ] [ 3 get instructions>> first ##load-double? ] unit-test
+
+    [ t ] [ 4 get instructions>> first ##phi? ] unit-test
+] when
\ No newline at end of file
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index 05e365e5e4..f202dc4c6a 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry accessors sequences assocs sets namespaces
 arrays combinators combinators.short-circuit math make locals
@@ -91,8 +91,8 @@ SYMBOL: possibilities
 : possible ( vreg -- reps ) possibilities get at ;
 
 : compute-possibilities ( cfg -- )
-    H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
-    [ keys ] assoc-map possibilities set ;
+    H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
+    [ members ] assoc-map possibilities set ;
 
 ! Compute vregs which must remain tagged for their lifetime.
 SYMBOL: always-boxed
@@ -119,15 +119,18 @@ SYMBOL: always-boxed
 SYMBOL: costs
 
 : init-costs ( -- )
-    possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+    possibilities get [ drop H{ } clone ] assoc-map costs set ;
+
+: record-possibility ( rep vreg -- )
+    costs get at [ 0 or ] change-at ;
 
 : increase-cost ( rep vreg -- )
     ! Increase cost of keeping vreg in rep, making a choice of rep less
     ! likely.
-    [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+    costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
 
 : maybe-increase-cost ( possible vreg preferred -- )
-    pick eq? [ 2drop ] [ increase-cost ] if ;
+    pick eq? [ record-possibility ] [ increase-cost ] if ;
 
 : representation-cost ( vreg preferred -- )
     ! 'preferred' is a representation that the instruction can accept with no cost.
@@ -137,11 +140,29 @@ SYMBOL: costs
     [ '[ _ _ maybe-increase-cost ] ]
     2bi each ;
 
+GENERIC: compute-insn-costs ( insn -- )
+
+M: ##load-constant compute-insn-costs
+    ! There's no cost to unboxing the result of a ##load-constant
+    drop ;
+
+M: insn compute-insn-costs [ representation-cost ] each-rep ;
+
 : compute-costs ( cfg -- costs )
-    init-costs [ representation-cost ] with-vreg-reps costs get ;
+    init-costs
+    [
+        [ basic-block set ]
+        [
+            [
+                compute-insn-costs
+            ] each-non-phi
+        ] bi
+    ] each-basic-block
+    costs get ;
 
 ! For every vreg, compute preferred representation, that minimizes costs.
 : minimize-costs ( costs -- representations )
+    [ nip assoc-empty? not ] assoc-filter
     [ >alist alist-min first ] assoc-map ;
 
 : compute-representations ( cfg -- )
@@ -150,6 +171,54 @@ SYMBOL: costs
     bi assoc-union
     representations set ;
 
+! PHI nodes require special treatment
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: phis
+
+: collect-phis ( cfg -- )
+    H{ } clone phis set
+    [
+        phis get
+        '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
+    ] each-basic-block ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+    work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+    representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+    representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+    phis get keys rep-assigned add-to-work-list ;
+
+: process-phi ( dst -- )
+    ! If dst = phi(src1,src2,...) and dst's representation has been
+    ! determined, assign that representation to each one of src1,...
+    ! that does not have a representation yet, and process those, too.
+    dup phis get at* [
+        [ rep-of ] [ rep-not-assigned ] bi*
+        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+    ] [ 2drop ] if ;
+
+: remaining-phis ( -- )
+    phis get keys rep-not-assigned { } assert-sequence= ;
+
+: process-phis ( -- )
+    <hashed-dlist> work-list set
+    add-ready-phis
+    work-list get [ process-phi ] slurp-deque
+    remaining-phis ;
+
+: compute-phi-representations ( cfg -- )
+    collect-phis process-phis ;
+
 ! Insert conversions. This introduces new temporaries, so we need
 ! to rename opearands too.
 
@@ -188,7 +257,7 @@ SYMBOLS: renaming-set needs-renaming? ;
 : record-renaming ( from to -- )
     2array renaming-set get push needs-renaming? on ;
 
-:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- new-vreg ) -- )
     vreg rep-of :> preferred
     preferred required eq?
     [ vreg no-renaming ]
@@ -217,15 +286,16 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ]
 
 GENERIC: conversions-for-insn ( insn -- )
 
-SYMBOL: phi-mappings
+M: ##phi conversions-for-insn , ;
 
-! compiler.cfg.cssa inserts conversions which convert phi inputs into
-!  the representation of the output. However, we still have to do some
-!  processing here, because if the only node that uses the output of
-!  the phi instruction is another phi instruction then this phi node's
-! output won't have a representation assigned.
-M: ##phi conversions-for-insn
-    [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+! When a float is unboxed, we replace the ##load-constant with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+    {
+        [ drop load-double? ]
+        [ dst>> rep-of double-rep? ]
+        [ obj>> float? ]
+    } 1&& ;
 
 ! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
 ! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
@@ -234,17 +304,25 @@ M: ##phi conversions-for-insn
         [ dst>> rep-of vector-rep? ]
         [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
     } 1&& ;
+
 : convert-to-fill-vector? ( insn -- ? )
     {
         [ dst>> rep-of vector-rep? ]
         [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
     } 1&& ;
 
+: (convert-to-load-double) ( insn -- dst val )
+    [ dst>> ] [ obj>> ] bi ; inline
+
 : (convert-to-zero/fill-vector) ( insn -- dst rep )
     dst>> dup rep-of ; inline
 
 : conversions-for-load-insn ( insn -- ?insn )
     {
+        {
+            [ dup convert-to-load-double? ]
+            [ (convert-to-load-double) ##load-double f ]
+        }
         {
             [ dup convert-to-zero-vector? ]
             [ (convert-to-zero/fill-vector) ##zero-vector f ]
@@ -277,46 +355,8 @@ M: insn conversions-for-insn , ;
         ] change-instructions drop
     ] if ;
 
-! If the output of a phi instruction is only used as the input to another
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
-    work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
-    representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
-    representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
-    phi-mappings get keys rep-assigned add-to-work-list ;
-
-: process-phi-mapping ( dst -- )
-    ! If dst = phi(src1,src2,...) and dst's representation has been
-    ! determined, assign that representation to each one of src1,...
-    ! that does not have a representation yet, and process those, too.
-    dup phi-mappings get at* [
-        [ rep-of ] [ rep-not-assigned ] bi*
-        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
-    ] [ 2drop ] if ;
-
-: remaining-phi-mappings ( -- )
-    phi-mappings get keys rep-not-assigned
-    [ [ int-rep ] dip set-rep-of ] each ;
-
-: process-phi-mappings ( -- )
-    <hashed-dlist> work-list set
-    add-ready-phis
-    work-list get [ process-phi-mapping ] slurp-deque
-    remaining-phi-mappings ;
-
 : insert-conversions ( cfg -- )
-    H{ } clone phi-mappings set
-    [ conversions-for-block ] each-basic-block
-    process-phi-mappings ;
+    [ conversions-for-block ] each-basic-block ;
 
 PRIVATE>
 
@@ -326,6 +366,7 @@ PRIVATE>
     {
         [ compute-possibilities ]
         [ compute-representations ]
+        [ compute-phi-representations ]
         [ insert-conversions ]
         [ ]
     } cleave
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index b16f471d11..99564b7e0e 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -81,6 +81,7 @@ SYNTAX: CODEGEN:
 CODEGEN: ##load-immediate %load-immediate
 CODEGEN: ##load-reference %load-reference
 CODEGEN: ##load-constant %load-reference
+CODEGEN: ##load-double %load-double
 CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
 CODEGEN: ##inc-d %inc-d
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index eef517a2bb..fa8dfc2149 100644
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -70,9 +70,12 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 : rel-word-pic-tail ( word class -- )
     [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
 
-: rel-immediate ( literal class -- )
+: rel-literal ( literal class -- )
     [ add-literal ] dip rt-literal rel-fixup ;
 
+: rel-float ( literal class -- )
+    [ add-literal ] dip rt-float rel-fixup ;
+
 : rel-this ( class -- )
     rt-this rel-fixup ;
 
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 2fec5ca190..0e2fc3041b 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -68,7 +68,8 @@ C-ENUM: f
     rt-vm
     rt-cards-offset
     rt-decks-offset
-    rt-exception-handler ;
+    rt-exception-handler
+    rt-float ;
 
 : rc-absolute? ( n -- ? )
     ${
diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor
index 42325d97ca..af2bdbda60 100644
--- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor
@@ -8,7 +8,7 @@ IN: compiler.tree.propagation.recursive.tests
     integer generalize-counter-interval
 ] unit-test
 
-[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+[ T{ interval f { 0 t } { $[ max-array-capacity ] t } } ] [
     T{ interval f { 1 t } { 1 t } }
     T{ interval f { 0 t } { 0 t } }
     fixnum generalize-counter-interval
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 0051e83356..a98b5cbafb 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -202,8 +202,9 @@ M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
 ! Mapping from register class to machine registers
 HOOK: machine-registers cpu ( -- assoc )
 
-HOOK: %load-immediate cpu ( reg obj -- )
+HOOK: %load-immediate cpu ( reg val -- )
 HOOK: %load-reference cpu ( reg obj -- )
+HOOK: %load-double cpu ( reg val -- )
 
 HOOK: %peek cpu ( vreg loc -- )
 HOOK: %replace cpu ( vreg loc -- )
@@ -496,6 +497,11 @@ M: reg-class param-reg param-regs nth ;
 
 M: stack-params param-reg 2drop ;
 
+! Does this architecture support %load-double?
+HOOK: load-double? cpu ( -- ? )
+
+M: object load-double? f ;
+
 ! Can this value be an immediate operand for %add-imm, %sub-imm,
 ! or %mul-imm?
 HOOK: immediate-arithmetic? cpu ( n -- ? )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 551693d5c7..edeb0d262f 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -47,7 +47,7 @@ CONSTANT: fp-scratch-reg 30
 M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 
 M: ppc %load-reference ( reg obj -- )
-    [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
+    [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
 
 M: ppc %alien-global ( register symbol dll -- )
     [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 00422dcf03..c567c1e1f0 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -12,9 +12,6 @@ cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
 FROM: layouts => cell ;
 IN: cpu.x86.32
 
-M: x86.32 immediate-comparand? ( n -- ? )
-    [ call-next-method ] [ word? ] bi or ;
-
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
@@ -27,6 +24,14 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 frame-reg EBP ;
 M: x86.32 temp-reg ECX ;
 
+M: x86.32 immediate-comparand? ( n -- ? )
+    [ call-next-method ] [ word? ] bi or ;
+
+M: x86.32 load-double? ( -- ? ) t ;
+
+M: x86.32 %load-double ( dst val -- )
+    [ 0 [] MOVSD ] dip rc-absolute rel-float ;
+
 M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index bab90c0f09..7bb33dec9a 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -66,7 +66,7 @@ HOOK: pic-tail-reg cpu ( -- reg )
 
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
 
-M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
+M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-literal ;
 
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
@@ -493,7 +493,7 @@ M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
 :: (%boolean) ( dst temp insn -- )
     dst \ f type-number MOV
-    temp 0 MOV \ t rc-absolute-cell rel-immediate
+    temp 0 MOV \ t rc-absolute-cell rel-literal
     dst temp insn execute ; inline
 
 : %boolean ( dst cc temp -- )
@@ -514,7 +514,7 @@ M:: x86 %compare ( dst src1 src2 cc temp -- )
     [ register? ] [ 0 = ] [ { cc= cc/= } member? ] tri* and and ;
 
 : (%compare-tagged) ( src1 src2 -- )
-    [ HEX: ffffffff CMP ] dip rc-absolute rel-immediate ;
+    [ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
 
 : (%compare-imm) ( src1 src2 cc -- )
     {
diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp
index de103cda12..2e7b8d4f09 100755
--- a/vm/code_blocks.cpp
+++ b/vm/code_blocks.cpp
@@ -265,6 +265,9 @@ struct initial_code_block_visitor {
 		case RT_LITERAL:
 			op.store_value(next_literal());
 			break;
+		case RT_FLOAT:
+			op.store_float(next_literal());
+			break;
 		case RT_ENTRY_POINT:
 			op.store_value(parent->compute_entry_point_address(next_literal()));
 			break;
diff --git a/vm/compaction.cpp b/vm/compaction.cpp
index 5e52c70b0c..34398e3d88 100644
--- a/vm/compaction.cpp
+++ b/vm/compaction.cpp
@@ -111,6 +111,9 @@ struct code_block_compaction_relocation_visitor {
 		case RT_LITERAL:
 			op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
 			break;
+		case RT_FLOAT:
+			op.store_float(slot_forwarder.visit_pointer(op.load_float(old_offset)));
+			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/image.cpp b/vm/image.cpp
index ccce96a952..4dfdc4242e 100755
--- a/vm/image.cpp
+++ b/vm/image.cpp
@@ -185,6 +185,9 @@ struct code_block_fixup_relocation_visitor {
 		case RT_LITERAL:
 			op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
 			break;
+		case RT_FLOAT:
+			op.store_float(data_visitor.visit_pointer(op.load_float(old_offset)));
+			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/instruction_operands.cpp b/vm/instruction_operands.cpp
index b11db279a5..af7d363aef 100644
--- a/vm/instruction_operands.cpp
+++ b/vm/instruction_operands.cpp
@@ -62,6 +62,16 @@ fixnum instruction_operand::load_value()
 	return load_value(pointer);
 }
 
+cell instruction_operand::load_float()
+{
+	return (cell)load_value() - boxed_float_offset;
+}
+
+cell instruction_operand::load_float(cell pointer)
+{
+	return (cell)load_value(pointer) - boxed_float_offset;
+}
+
 code_block *instruction_operand::load_code_block(cell relative_to)
 {
 	return ((code_block *)load_value(relative_to) - 1);
@@ -135,6 +145,11 @@ void instruction_operand::store_value(fixnum absolute_value)
 	}
 }
 
+void instruction_operand::store_float(cell value)
+{
+	store_value((fixnum)value + boxed_float_offset);
+}
+
 void instruction_operand::store_code_block(code_block *compiled)
 {
 	store_value((cell)compiled->entry_point());
diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp
index 5dda411c8b..5c120c2ec7 100644
--- a/vm/instruction_operands.hpp
+++ b/vm/instruction_operands.hpp
@@ -30,6 +30,9 @@ enum relocation_type {
 	type since its used in a situation where relocation arguments cannot
 	be passed in, and so RT_DLSYM is inappropriate (Windows only) */
 	RT_EXCEPTION_HANDLER,
+	/* pointer to a float's payload */
+	RT_FLOAT,
+
 };
 
 enum relocation_class {
@@ -112,6 +115,7 @@ struct relocation_entry {
 		case RT_CARDS_OFFSET:
 		case RT_DECKS_OFFSET:
 		case RT_EXCEPTION_HANDLER:
+		case RT_FLOAT:
 			return 0;
 		default:
 			critical_error("Bad rel type",rel_type());
@@ -152,12 +156,15 @@ struct instruction_operand {
 	fixnum load_value_masked(cell mask, cell bits, cell shift);
 	fixnum load_value(cell relative_to);
 	fixnum load_value();
+	cell load_float(cell relative_to);
+	cell load_float();
 	code_block *load_code_block(cell relative_to);
 	code_block *load_code_block();
 
 	void store_value_2_2(fixnum value);
 	void store_value_masked(fixnum value, cell mask, cell shift);
 	void store_value(fixnum value);
+	void store_float(cell value);
 	void store_code_block(code_block *compiled);
 };
 
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 9b574e554d..3e51d1fa4d 100644
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -246,6 +246,8 @@ struct wrapper : public object {
 	cell object;
 };
 
+const fixnum boxed_float_offset = 8 - FLOAT_TYPE;
+
 /* Assembly code makes assumptions about the layout of this struct */
 struct boxed_float : object {
 	static const cell type_number = FLOAT_TYPE;
diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp
index d4dd44bed1..cb2db1c705 100644
--- a/vm/slot_visitor.hpp
+++ b/vm/slot_visitor.hpp
@@ -192,8 +192,17 @@ struct literal_references_visitor {
 
 	void operator()(instruction_operand op)
 	{
-		if(op.rel_type() == RT_LITERAL)
+		switch(op.rel_type())
+		{
+		case RT_LITERAL:
 			op.store_value(visitor->visit_pointer(op.load_value()));
+			break;
+		case RT_FLOAT:
+			op.store_float(visitor->visit_pointer(op.load_float()));
+			break;
+		default:
+			break;
+		}
 	}
 };