[project @ 2000-01-24 17:24:23 by sewardj]

Major reworking of the x86 floating point code generation.

Intel, in their infinite wisdom, selected a stack model for floating
point registers on x86.  That might have made sense back in 1979 --
nowadays we can see it for the nonsense it really is.  A stack model
fits poorly with the existing nativeGen infrastructure, which assumes
flat integer and FP register sets.  Prior to this commit, nativeGen
could not generate correct x86 FP code -- to do so would have meant
somehow working the register-stack paradigm into the register
allocator and spiller, which sounds very difficult.

We have decided to cheat, and go for a simple fix which requires no
infrastructure modifications, at the expense of generating ropey but
correct FP code.  All notions of the x86 FP stack and its insns have
been removed.  Instead, we pretend (to the instruction selector and
register allocator) that x86 has six floating point registers, %fake0
.. %fake5, which can be used in the usual flat manner.  We further
claim that x86 has floating point instructions very similar to SPARC
and Alpha, that is, a simple 3-operand register-register arrangement.
Code generation and register allocation proceed on this basis.

When we come to print out the final assembly, our convenient fiction
is converted to dismal reality.  Each fake instruction is
independently converted to a series of real x86 instructions.
%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg
arithmetic operations, the two operands are pushed onto the top of the
FP stack, the operation done, and the result copied back into the
relevant register.  There are only six %fake registers because 2 are
needed for the translation, and x86 has 8 in total.

The translation is inefficient but is simple and it works.  A cleverer
translation would handle a sequence of insns, simulating the FP stack
contents, would not impose a fixed mapping from %fake to %st regs, and
hopefully could avoid most of the redundant reg-reg moves of the
current translation.

7 files changed, 442 insertions, 512 deletions

diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 9309d475db..13a59ef22b 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -84,18 +84,10 @@ nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc)
 nativeCodeGen absC us
    = let (stixRaw, us1) = initUs us (genCodeAbstractC absC)
          stixOpt        = map (map genericOpt) stixRaw
-         stixFinal      = map x86floatFix stixOpt
-         insns          = initUs_ us1 (codeGen stixFinal)
-         debug_stix     = vcat (map pprStixTrees stixFinal)
+         insns          = initUs_ us1 (codeGen stixOpt)
+         debug_stix     = vcat (map pprStixTrees stixOpt)
      in 
          (debug_stix, insns)
-
-#if i386_TARGET_ARCH
-x86floatFix = floatFix
-#else
-x86floatFix = id
-#endif
-
 \end{code}
 
 @codeGen@ is the top-level code-generation function:
@@ -108,7 +100,10 @@ codeGen stixFinal
 	static_instrss = scheduleMachCode dynamic_codes
         docs           = map (vcat . map pprInstr) static_instrss       
     in
-    returnUs (vcat (intersperse (char ' ' $$ char ' ') docs))
+    returnUs (vcat (intersperse (char ' ' 
+                                 $$ text "# ___stg_split_marker" 
+                                 $$ char ' ') 
+                    docs))
 \end{code}
 
 Top level code generator for a chunk of stix code:
@@ -292,64 +287,3 @@ Anything else is just too hard.
 \begin{code}
 primOpt op args = StPrim op args
 \end{code}
-
------------------------------------------------------------------------------
-Fix up floating point operations for x86.
-
-The problem is that the code generator can't handle the weird register
-naming scheme for floating point registers on the x86, so we have to
-deal with memory-resident floating point values wherever possible.
-
-We therefore can't stand references to floating-point kinded temporary
-variables, and try to translate them into memory addresses wherever
-possible.
-
-\begin{code}
-floatFix :: [StixTree] -> [StixTree]
-floatFix trees = fltFix emptyUFM trees
-
-fltFix 	:: UniqFM StixTree	-- mapping tmp vars to memory locations
-      	-> [StixTree]
-	-> [StixTree]
-fltFix locs [] = []
-
--- The case we're interested in: loading a temporary from a memory
--- address.  Eliminate the instruction and replace all future references
--- to the temporary with the memory address.
-fltFix locs ((StAssign rep (StReg (StixTemp uq _)) loc) : trees)
-  | isFloatingRep rep  = fltFix (addToUFM locs uq loc) trees
-
-fltFix locs ((StAssign rep src dst) : trees)
-  = StAssign rep (fltFix1 locs src) (fltFix1 locs dst) : fltFix locs trees
-  
-fltFix locs (tree : trees)
-  = fltFix1 locs tree : fltFix locs trees
-
-
-fltFix1 :: UniqFM StixTree -> StixTree -> StixTree
-fltFix1 locs r@(StReg (StixTemp uq rep))
-  | isFloatingRep rep = case lookupUFM locs uq of
-			 	Nothing   -> panic "fltFix1"
-				Just tree -> tree
-
-fltFix1 locs (StIndex rep l r) =
-  StIndex rep (fltFix1 locs l) (fltFix1 locs r)
-
-fltFix1 locs (StInd rep tree) =
-  StInd rep (fltFix1 locs tree)
-
-fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign"
-
-fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree)
-
-fltFix1 locs (StCondJump lbl tree) =
-  StCondJump lbl (fltFix1 locs tree)
-
-fltFix1 locs (StPrim op trees) = 
-  StPrim op (map (fltFix1 locs) trees)
-
-fltFix1 locs (StCall f conv rep trees) =
-  StCall f conv rep (map (fltFix1 locs) trees)
- 
-fltFix1 locs tree = tree
-\end{code}
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 86d3c31984..7ba0869e08 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -247,7 +247,7 @@ getRegister (StCall fn cconv kind args)
     returnUs (Fixed kind reg call)
   where
     reg = if isFloatingRep kind
-	  then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
+	  then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
 	  else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
 
 getRegister (StString s)
@@ -505,42 +505,32 @@ getRegister leaf
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if i386_TARGET_ARCH
 
-getRegister (StDouble 0.0)
-  = let
-    	code dst = mkSeqInstrs [FLDZ]
-    in
-    returnUs (Any DoubleRep code)
-
-getRegister (StDouble 1.0)
-  = let
-    	code dst = mkSeqInstrs [FLD1]
-    in
-    returnUs (Any DoubleRep code)
-
 getRegister (StDouble d)
   = getUniqLabelNCG 	    	    `thenUs` \ lbl ->
-    --getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let code dst = mkSeqInstrs [
     	    SEGMENT DataSegment,
 	    LABEL lbl,
 	    DATA DF [ImmDouble d],
 	    SEGMENT TextSegment,
-	    FLD DF (OpImm (ImmCLbl lbl))
+	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
 	    ]
     in
     returnUs (Any DoubleRep code)
 
+
 getRegister (StPrim primop [x]) -- unary PrimOps
   = case primop of
       IntNegOp  -> trivialUCode (NEGI L) x
-
       NotOp	-> trivialUCode (NOT L) x
 
-      FloatNegOp  -> trivialUFCode FloatRep FCHS x
-      FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
-      DoubleNegOp -> trivialUFCode DoubleRep FCHS x
+      FloatNegOp  -> trivialUFCode FloatRep  (GNEG F) x
+      DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
+
+      FloatSqrtOp  -> trivialUFCode FloatRep  (GSQRT F) x
+      DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
 
-      DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+      Double2FloatOp -> trivialUFCode FloatRep  GDTOF x
+      Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
 
       OrdOp -> coerceIntCode IntRep x
       ChrOp -> chrCode x
@@ -550,14 +540,11 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Double2IntOp -> coerceFP2Int x
       Int2DoubleOp -> coerceInt2FP DoubleRep x
 
-      Double2FloatOp -> coerceFltCode x
-      Float2DoubleOp -> coerceFltCode x
-
       other_op ->
         let
-	    fixed_x = if is_float_op  -- promote to double
-			  then StPrim Float2DoubleOp [x]
-			  else x
+	    fixed_x = if   is_float_op  -- promote to double
+		      then StPrim Float2DoubleOp [x]
+		      else x
 	in
 	getRegister (StCall fn cCallConv DoubleRep [x])
        where
@@ -651,15 +638,15 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       IntRemOp  -> quot_code L x y False{-remainder-}
       IntMulOp  -> trivialCode (IMUL L) x y {-True-}
 
-      FloatAddOp -> trivialFCode  FloatRep  FADD FADD  FADDP FADDP  x y
-      FloatSubOp -> trivialFCode  FloatRep  FSUB FSUBR FSUBP FSUBRP x y
-      FloatMulOp -> trivialFCode  FloatRep  FMUL FMUL  FMULP FMULP  x y
-      FloatDivOp -> trivialFCode  FloatRep  FDIV FDIVR FDIVP FDIVRP x y
+      FloatAddOp -> trivialFCode  FloatRep  GADD x y
+      FloatSubOp -> trivialFCode  FloatRep  GSUB x y
+      FloatMulOp -> trivialFCode  FloatRep  GMUL x y
+      FloatDivOp -> trivialFCode  FloatRep  GDIV x y
 
-      DoubleAddOp -> trivialFCode DoubleRep FADD FADD  FADDP FADDP  x y
-      DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
-      DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL  FMULP FMULP  x y
-      DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
+      DoubleAddOp -> trivialFCode DoubleRep GADD x y
+      DoubleSubOp -> trivialFCode DoubleRep GSUB x y
+      DoubleMulOp -> trivialFCode DoubleRep GMUL x y
+      DoubleDivOp -> trivialFCode DoubleRep GDIV x y
 
       AndOp -> trivialCode (AND L) x y {-True-}
       OrOp  -> trivialCode (OR L)  x y {-True-}
@@ -673,18 +660,23 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       SllOp -> shift_code (SHL L) x y {-False-}
       SrlOp -> shift_code (SHR L) x y {-False-}
 
-      ISllOp -> shift_code (SHL L) x y {-False-}  --was:panic "I386Gen:isll"
-      ISraOp -> shift_code (SAR L) x y {-False-}  --was:panic "I386Gen:isra"
-      ISrlOp -> shift_code (SHR L) x y {-False-}  --was:panic "I386Gen:isrl"
+      ISllOp -> shift_code (SHL L) x y {-False-}
+      ISraOp -> shift_code (SAR L) x y {-False-}
+      ISrlOp -> shift_code (SHR L) x y {-False-}
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
+                                           [promote x, promote y])
 		       where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
+      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
+                                           [x, y])
   where
+
+    --------------------
     shift_code :: (Operand -> Operand -> Instr)
 	       -> StixTree
 	       -> StixTree
 	       -> UniqSM Register
+
       {- Case1: shift length as immediate -}
       -- Code is the same as the first eq. for trivialCode -- sigh.
     shift_code instr x y{-amount-}
@@ -715,7 +707,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
     shift_code instr x y{-amount-}
      = getRegister y		`thenUs` \ register1 ->  
        getRegister x		`thenUs` \ register2 ->
---       getNewRegNCG IntRep	`thenUs` \ dst ->
        let
 	-- Note: we force the shift length to be loaded
 	-- into ECX, so that we can use CL when shifting.
@@ -740,6 +731,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
        in
        returnUs (Fixed IntRep eax code__2)
 
+    --------------------
     add_code :: Size -> StixTree -> StixTree -> UniqSM Register
 
     add_code sz x (StInt y)
@@ -749,51 +741,13 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 	    code = registerCode register tmp
 	    src1 = registerName register tmp
 	    src2 = ImmInt (fromInteger y)
-	    code__2 dst = code .
-			  mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
-	in
-	returnUs (Any IntRep code__2)
-{-
-    add_code sz x (StInd _ mem)
-      = getRegister x		`thenUs` \ register1 ->
-	--getNewRegNCG (registerRep register1)
-	--			`thenUs` \ tmp1 ->
-	getAmode mem		`thenUs` \ amode ->
-	let
-	    code2 = amodeCode amode
-	    src2  = amodeAddr amode
-
-	    code__2 dst = let code1 = registerCode register1 dst
-			      src1  = registerName register1 dst
-			  in asmParThen [code2 asmVoid,code1 asmVoid] .
-			     if isFixed register1 && src1 /= dst
-			     then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-					       ADD sz (OpAddr src2)  (OpReg dst)]
-			     else
-				    mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+	    code__2 dst 
+               = code .
+		 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) 
+                                    (OpReg dst))
 	in
 	returnUs (Any IntRep code__2)
 
-    add_code sz (StInd _ mem) y
-      = getRegister y		`thenUs` \ register2 ->
-	--getNewRegNCG (registerRep register2)
-	--			`thenUs` \ tmp2 ->
-	getAmode mem		`thenUs` \ amode ->
-	let
-	    code1 = amodeCode amode
-	    src1  = amodeAddr amode
-
-	    code__2 dst = let code2 = registerCode register2 dst
-			      src2  = registerName register2 dst
-			  in asmParThen [code1 asmVoid,code2 asmVoid] .
-			     if isFixed register2 && src2 /= dst
-			     then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
-					       ADD sz (OpAddr src1)  (OpReg dst)]
-			     else
-				    mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
-	in
-	returnUs (Any IntRep code__2)
--}
     add_code sz x y
       = getRegister x		`thenUs` \ register1 ->
 	getRegister y		`thenUs` \ register2 ->
@@ -804,8 +758,11 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 	    src1  = registerName register1 tmp1
 	    code2 = registerCode register2 tmp2 asmVoid
 	    src2  = registerName register2 tmp2
-	    code__2 dst = asmParThen [code1, code2] .
-			  mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+	    code__2 dst 
+               = asmParThen [code1, code2] .
+		 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) 
+                                                           (ImmInt 0))) 
+                                    (OpReg dst))
 	in
 	returnUs (Any IntRep code__2)
 
@@ -819,8 +776,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 	    code = registerCode register tmp
 	    src1 = registerName register tmp
 	    src2 = ImmInt (-(fromInteger y))
-	    code__2 dst = code .
-			  mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
+	    code__2 dst 
+               = code .
+		 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+                                    (OpReg dst))
 	in
 	returnUs (Any IntRep code__2)
 
@@ -863,10 +822,14 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 	    src2    = ImmInt (fromInteger i)
 	    code__2 = asmParThen [code1] .
 		      mkSeqInstrs [-- we put src2 in (ebx)
-				   MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
-				   MOV L (OpReg src1) (OpReg eax),
-				   CLTD,
-				   IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+		         MOV L (OpImm src2) 
+                               (OpAddr (AddrBaseIndex (Just ebx) Nothing 
+                                                      (ImmInt OFFSET_R1))),
+			 MOV L (OpReg src1) (OpReg eax),
+			 CLTD,
+			 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing 
+                                         (ImmInt OFFSET_R1)))
+                      ]
 	in
 	returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
 
@@ -882,14 +845,20 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 	    src2    = registerName register2 tmp2
 	    code__2 = asmParThen [code1, code2] .
 		      if src2 == ecx || src2 == esi
-		      then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
-					 CLTD,
-					 IDIV sz (OpReg src2)]
+		      then mkSeqInstrs [ 
+                              MOV L (OpReg src1) (OpReg eax),
+			      CLTD,
+			      IDIV sz (OpReg src2)
+                           ]
 		      else mkSeqInstrs [ -- we put src2 in (ebx)
-					 MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
-					 MOV L (OpReg src1) (OpReg eax),
-					 CLTD,
-					 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+			      MOV L (OpReg src2) 
+                                    (OpAddr (AddrBaseIndex (Just ebx) Nothing 
+                                                           (ImmInt OFFSET_R1))),
+			      MOV L (OpReg src1) (OpReg eax),
+			      CLTD,
+			      IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing 
+                                                             (ImmInt OFFSET_R1)))
+                           ]
 	in
 	returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
 	-----------------------
@@ -898,16 +867,15 @@ getRegister (StInd pk mem)
   = getAmode mem    	    	    `thenUs` \ amode ->
     let
     	code = amodeCode amode
-    	src   = amodeAddr amode
+    	src  = amodeAddr amode
     	size = primRepToSize pk
     	code__2 dst = code .
 		      if pk == DoubleRep || pk == FloatRep
-		      then mkSeqInstr (FLD {-DF-} size (OpAddr src))
+		      then mkSeqInstr (GLD size src dst)
 		      else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
     in
     	returnUs (Any pk code__2)
 
-
 getRegister (StInt i)
   = let
     	src = ImmInt (fromInteger i)
@@ -1485,26 +1453,6 @@ condIntCode cond x y
     returnUs (CondCode False cond code__2)
 
 -----------
-
-condFltCode cond x (StDouble 0.0)
-  = getRegister x		`thenUs` \ register1 ->
-    getNewRegNCG (registerRep register1)
-      	    	        	`thenUs` \ tmp1 ->
-    let
-    	pk1   = registerRep register1
-    	code1 = registerCode register1 tmp1
-    	src1  = registerName register1 tmp1
-
-    	code__2 = asmParThen [code1 asmVoid] .
-    	    	  mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
-			       FNSTSW,
-			       --AND HB (OpImm (ImmInt 68)) (OpReg eax),
-			       --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
-			       SAHF
-			      ]
-    in
-    returnUs (CondCode True (fix_FP_cond cond) code__2)
-
 condFltCode cond x y
   = getRegister x		`thenUs` \ register1 ->
     getRegister y		`thenUs` \ register2 ->
@@ -1512,35 +1460,33 @@ condFltCode cond x y
       	    	        	`thenUs` \ tmp1 ->
     getNewRegNCG (registerRep register2)
      	    	        	`thenUs` \ tmp2 ->
+    getNewRegNCG DoubleRep	`thenUs` \ tmp ->
     let
     	pk1   = registerRep register1
     	code1 = registerCode register1 tmp1
     	src1  = registerName register1 tmp1
 
+    	pk2   = registerRep register2
     	code2 = registerCode register2 tmp2
     	src2  = registerName register2 tmp2
 
-    	code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
-    	    	  mkSeqInstrs [FUCOMPP,
-			       FNSTSW,
-			       --AND HB (OpImm (ImmInt 68)) (OpReg eax),
-			       --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
-			       SAHF
-			      ]
+    	code__2 =   asmParThen [code1 asmVoid, code2 asmVoid] .
+    	    	    mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
+
+        {- On the 486, the flags set by FP compare are the unsigned ones!
+           (This looks like a HACK to me.  WDP 96/03)
+        -}
+        fix_FP_cond :: Cond -> Cond
+
+        fix_FP_cond GE  = GEU
+        fix_FP_cond GTT  = GU
+        fix_FP_cond LTT  = LU
+        fix_FP_cond LE  = LEU
+        fix_FP_cond any = any
     in
     returnUs (CondCode True (fix_FP_cond cond) code__2)
 
-{- On the 486, the flags set by FP compare are the unsigned ones!
-   (This looks like a HACK to me.  WDP 96/03)
--}
-
-fix_FP_cond :: Cond -> Cond
 
-fix_FP_cond GE  = GEU
-fix_FP_cond GTT  = GU
-fix_FP_cond LTT  = LU
-fix_FP_cond LE  = LEU
-fix_FP_cond any = any
 
 #endif {- i386_TARGET_ARCH -}
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -1798,7 +1744,6 @@ assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
   = getNewRegNCG IntRep       	    `thenUs` \ tmp ->
     getAmode src    	    	    `thenUs` \ amodesrc ->
     getAmode dst    	    	    `thenUs` \ amodedst ->
-    --getRegister src	    	    	    `thenUs` \ register ->
     let
     	codesrc1 = amodeCode amodesrc asmVoid
     	addrsrc1 = amodeAddr amodesrc
@@ -1819,38 +1764,38 @@ assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
     returnUs code__2
 
 assignFltCode pk (StInd _ dst) src
-  = --getNewRegNCG pk        	    `thenUs` \ tmp ->
+  = getNewRegNCG pk        	    `thenUs` \ tmp ->
     getAmode dst    	    	    `thenUs` \ amode ->
-    getRegister src	    	    	    `thenUs` \ register ->
+    getRegister src	    	    `thenUs` \ register ->
     let
     	sz      = primRepToSize pk
     	dst__2  = amodeAddr amode
 
     	code1   = amodeCode amode asmVoid
-    	code2   = registerCode register {-tmp-}st0 asmVoid
+    	code2   = registerCode register tmp asmVoid
 
-    	--src__2= registerName register tmp
-    	pk__2   = registerRep register
-    	sz__2   = primRepToSize pk__2
+    	src__2  = registerName register tmp
 
     	code__2 = asmParThen [code1, code2] .
-		  mkSeqInstr (FSTP sz (OpAddr dst__2))
+		  mkSeqInstr (GST sz src__2 dst__2)
     in
     returnUs code__2
 
 assignFltCode pk dst src
   = getRegister dst	    	    	    `thenUs` \ register1 ->
     getRegister src	    	    	    `thenUs` \ register2 ->
-    --getNewRegNCG (registerRep register2)
-    --	    	        	    `thenUs` \ tmp ->
+    getNewRegNCG pk                         `thenUs` \ tmp ->
     let
-    	sz      = primRepToSize pk
-    	dst__2  = registerName register1 st0 --tmp
-
-    	code    = registerCode register2 dst__2
+        -- the register which is dst
+    	dst__2  = registerName register1 tmp
+        -- the register into which src is computed, preferably dst__2
     	src__2  = registerName register2 dst__2
+        -- code to compute src into src__2
+    	code    = registerCode register2 dst__2
 
-    	code__2 = code
+    	code__2 = if isFixed register2
+                  then code . mkSeqInstr (GMOV src__2 dst__2)
+                  else code
     in
     returnUs code__2
 
@@ -2345,22 +2290,23 @@ genCCall fn cconv kind args
     get_call_arg arg
       = get_op arg		`thenUs` \ (code, op, sz) ->
         case sz of
-           DF -> returnUs (sz,
+           DF -> --getNewRegNCG DoubleRep `thenUs` \ tmp ->
+                 returnUs (sz,
                            code .
-                           mkSeqInstr (FLD L op) .
+                           --mkSeqInstr (GLD DF op tmp) .
                            mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) .
-                           mkSeqInstr (FSTP DF (OpAddr (AddrBaseIndex 
+                           mkSeqInstr (GST DF {-tmp-}op (AddrBaseIndex 
                                                           (Just esp) 
-                                                          Nothing (ImmInt 0))))
+                                                          Nothing (ImmInt 0)))
                           )
 	   _  -> returnUs (sz,
-                           code . mkSeqInstr (PUSH sz op))
+                           code . mkSeqInstr (PUSH sz (OpReg op)))
 
     ------------
     get_op
 	:: StixTree
-	-> UniqSM (InstrBlock,Operand, Size)	-- code, operator, size
-
+	-> UniqSM (InstrBlock, {-Operand-}Reg, Size)	-- code, operator, size
+{-
     get_op (StInt i)
       = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
 
@@ -2372,7 +2318,7 @@ genCCall fn cconv kind args
 	    sz	 = primRepToSize pk
 	in
 	returnUs (code, OpAddr addr, sz)
-
+-}
     get_op op
       = getRegister op		`thenUs` \ register ->
 	getNewRegNCG (registerRep register)
@@ -2383,7 +2329,7 @@ genCCall fn cconv kind args
 	    pk   = registerRep  register
 	    sz   = primRepToSize pk
 	in
-	returnUs (code, OpReg reg, sz)
+	returnUs (code, {-OpReg-} reg, sz)
 
 #endif {- i386_TARGET_ARCH -}
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -2665,12 +2611,7 @@ trivialFCode
     :: PrimRep
     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
-      ,IF_ARCH_i386 (
-	      {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
-	       (Size -> Operand -> Instr)
-	    -> (Size -> Operand -> Instr) {-reversed instr-}
-	    -> Instr {-pop-}
-	    -> Instr {-reversed instr: pop-}
+      ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
       ,)))
     -> StixTree -> StixTree -- the two arguments
     -> UniqSM Register
@@ -2686,7 +2627,7 @@ trivialUCode
 trivialUFCode
     :: PrimRep
     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
-      ,IF_ARCH_i386 (Instr
+      ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
       ,)))
     -> StixTree -- the one argument
@@ -2767,7 +2708,6 @@ trivialUFCode _ instr x
 trivialCode instr x y
   | maybeToBool imm
   = getRegister x		`thenUs` \ register1 ->
-    --getNewRegNCG IntRep	`thenUs` \ tmp1 ->
     let
     	code__2 dst = let code1 = registerCode register1 dst
     	                  src1  = registerName register1 dst
@@ -2786,7 +2726,6 @@ trivialCode instr x y
 trivialCode instr x y
   | maybeToBool imm
   = getRegister y		`thenUs` \ register1 ->
-    --getNewRegNCG IntRep	`thenUs` \ tmp1 ->
     let
     	code__2 dst = let code1 = registerCode register1 dst
 			  src1  = registerName register1 dst
@@ -2801,48 +2740,10 @@ trivialCode instr x y
   where
     imm = maybeImm x
     imm__2 = case imm of Just x -> x
-{-
-trivialCode instr x (StInd pk mem)
-  = getRegister x		`thenUs` \ register ->
-    --getNewRegNCG IntRep	`thenUs` \ tmp ->
-    getAmode mem		`thenUs` \ amode ->
-    let
-    	code2 = amodeCode amode asmVoid
-    	src2  = amodeAddr amode
-    	code__2 dst = let code1 = registerCode register dst asmVoid
-			  src1  = registerName register dst
-		      in asmParThen [code1, code2] .
-			 if isFixed register && src1 /= dst
-			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-					   instr (OpAddr src2)  (OpReg dst)]
-			 else
-				mkSeqInstr (instr (OpAddr src2) (OpReg src1))
-    in
-    returnUs (Any pk code__2)
 
-trivialCode instr (StInd pk mem) y
-  = getRegister y		`thenUs` \ register ->
-    --getNewRegNCG IntRep	`thenUs` \ tmp ->
-    getAmode mem		`thenUs` \ amode ->
-    let
-    	code2 = amodeCode amode asmVoid
-    	src2  = amodeAddr amode
-    	code__2 dst = let
-    	                  code1 = registerCode register dst asmVoid
-    	                  src1  = registerName register dst
-		      in asmParThen [code1, code2] .
-			 if isFixed register && src1 /= dst
-			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-					   instr (OpAddr src2)  (OpReg dst)]
-			 else
-				mkSeqInstr (instr (OpAddr src2) (OpReg src1))
-    in
-    returnUs (Any pk code__2)
--}
 trivialCode instr x y
   = getRegister x		`thenUs` \ register1 ->
     getRegister y		`thenUs` \ register2 ->
-    --getNewRegNCG IntRep	`thenUs` \ tmp1 ->
     getNewRegNCG IntRep		`thenUs` \ tmp2 ->
     let
     	code2 = registerCode register2 tmp2 asmVoid
@@ -2862,7 +2763,6 @@ trivialCode instr x y
 -----------
 trivialUCode instr x
   = getRegister x		`thenUs` \ register ->
---    getNewRegNCG IntRep	`thenUs` \ tmp ->
     let
     	code__2 dst = let
     	                  code = registerCode register dst
@@ -2875,10 +2775,9 @@ trivialUCode instr x
     returnUs (Any IntRep code__2)
 
 -----------
+{-
 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
   = getRegister y		`thenUs` \ register2 ->
-    --getNewRegNCG (registerRep register2)
-    --				`thenUs` \ tmp2 ->
     getAmode mem		`thenUs` \ amode ->
     let
     	code1 = amodeCode amode
@@ -2894,8 +2793,6 @@ trivialFCode pk _ instrr _ _ (StInd pk' mem) y
 
 trivialFCode pk instr _ _ _ x (StInd pk' mem)
   = getRegister x		`thenUs` \ register1 ->
-    --getNewRegNCG (registerRep register1)
-    --				`thenUs` \ tmp1 ->
     getAmode mem		`thenUs` \ amode ->
     let
     	code2 = amodeCode amode
@@ -2912,10 +2809,6 @@ trivialFCode pk instr _ _ _ x (StInd pk' mem)
 trivialFCode pk _ _ _ instrpr x y
   = getRegister x		`thenUs` \ register1 ->
     getRegister y		`thenUs` \ register2 ->
-    --getNewRegNCG (registerRep register1)
-    --				`thenUs` \ tmp1 ->
-    --getNewRegNCG (registerRep register2)
-    --				`thenUs` \ tmp2 ->
     getNewRegNCG DoubleRep	`thenUs` \ tmp ->
     let
     	pk1   = registerRep register1
@@ -2931,8 +2824,38 @@ trivialFCode pk _ _ _ instrpr x y
     	    	         mkSeqInstr instrpr
     in
     returnUs (Any pk1 code__2)
+-}
+
+trivialFCode pk instr x y
+  = getRegister x		`thenUs` \ register1 ->
+    getRegister y		`thenUs` \ register2 ->
+    getNewRegNCG DoubleRep	`thenUs` \ tmp1 ->
+    getNewRegNCG DoubleRep	`thenUs` \ tmp2 ->
+    let
+    	code1 = registerCode register1 tmp1
+    	src1  = registerName register1 tmp1
+
+    	code2 = registerCode register2 tmp2
+    	src2  = registerName register2 tmp2
+
+    	code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
+    	    	      mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+    in
+    returnUs (Any DoubleRep code__2)
+
 
 -------------
+trivialUFCode pk instr x
+  = getRegister x		`thenUs` \ register ->
+    getNewRegNCG pk		`thenUs` \ tmp ->
+    let
+    	code = registerCode register tmp
+    	src  = registerName register tmp
+    	code__2 dst = code . mkSeqInstr (instr src dst)
+    in
+    returnUs (Any pk code__2)
+
+{-
 trivialUFCode pk instr (StInd pk' mem)
   = getAmode mem		`thenUs` \ amode ->
     let
@@ -2945,7 +2868,6 @@ trivialUFCode pk instr (StInd pk' mem)
 
 trivialUFCode pk instr x
   = getRegister x		`thenUs` \ register ->
-    --getNewRegNCG pk		`thenUs` \ tmp ->
     let
     	code__2 dst = let
     	                  code = registerCode register dst
@@ -2953,7 +2875,7 @@ trivialUFCode pk instr x
 		      in code . mkSeqInstrs [instr]
     in
     returnUs (Any pk code__2)
-
+-}
 #endif {- i386_TARGET_ARCH -}
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if sparc_TARGET_ARCH
@@ -3124,11 +3046,9 @@ coerceInt2FP pk x
     let
     	code = registerCode register reg
     	src  = registerName register reg
-
-    	code__2 dst = code . mkSeqInstrs [
-	-- to fix: should spill instead of using R1
-    	              MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
-    	              FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+        opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
+        code__2 dst = code . 
+                      mkSeqInstr (opc src dst)
     in
     returnUs (Any pk code__2)
 
@@ -3141,10 +3061,9 @@ coerceFP2Int x
     	src  = registerName register tmp
     	pk   = registerRep register
 
-    	code__2 dst = code . mkSeqInstrs [
-    	                        FRNDINT,
-    	                        FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
-    	                        MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+        opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
+        code__2 dst = code . 
+                      mkSeqInstr (opc src dst)
     in
     returnUs (Any IntRep code__2)
 
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index 3c593e0567..d72de134ed 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -475,49 +475,34 @@ data RI
 
 -- Float Arithmetic. -- ToDo for 386
 
--- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
+-- Note that we cheat by treating G{ABS,MOV,NEG} of doubles as single instructions
 -- right up until we spit them out.
 
-	      | SAHF	      -- stores ah into flags
-    	      | FABS
-	      | FADD	      Size Operand -- src
-	      | FADDP
-	      | FIADD	      Size MachRegsAddr -- src
-    	      | FCHS
-    	      | FCOM	      Size Operand -- src
-    	      | FCOS
-	      | FDIV	      Size Operand -- src
-	      | FDIVP
-	      | FIDIV	      Size MachRegsAddr -- src
-	      | FDIVR	      Size Operand -- src
-	      | FDIVRP
-	      | FIDIVR	      Size MachRegsAddr -- src
-    	      | FICOM	      Size MachRegsAddr -- src
-    	      | FILD	      Size MachRegsAddr Reg -- src, dst
-    	      | FIST	      Size MachRegsAddr -- dst
-    	      | FLD	      Size Operand -- src
-    	      | FLD1
-    	      | FLDZ
-    	      | FMUL	      Size Operand -- src
-    	      | FMULP
-    	      | FIMUL	      Size MachRegsAddr -- src
-    	      | FRNDINT
-    	      | FSIN
-    	      | FSQRT
-    	      | FST	      Size Operand -- dst
-    	      | FSTP	      Size Operand -- dst
-	      | FSUB	      Size Operand -- src
-	      | FSUBP
-	      | FISUB	      Size MachRegsAddr -- src
-	      | FSUBR	      Size Operand -- src
-	      | FSUBRP
-	      | FISUBR	      Size MachRegsAddr -- src
-	      | FTST
-    	      | FCOMP	      Size Operand -- src
-    	      | FUCOMPP
-	      | FXCH
-	      | FNSTSW
-	      | FNOP
+              -- all the 3-operand fake fp insns are src1 src2 dst
+              -- and furthermore are constrained to be fp regs only.
+    	      | GMOV	      Reg Reg -- src(fpreg), dst(fpreg)
+              | GLD           Size MachRegsAddr Reg -- src, dst(fpreg)
+              | GST           Size Reg MachRegsAddr -- src(fpreg), dst
+
+    	      | GFTOD	      Reg Reg -- src(fpreg), dst(fpreg)
+              | GFTOI         Reg Reg -- src(fpreg), dst(intreg)
+
+    	      | GDTOF	      Reg Reg -- src(fpreg), dst(fpreg)
+              | GDTOI         Reg Reg -- src(fpreg), dst(intreg)
+
+              | GITOF         Reg Reg -- src(intreg), dst(fpreg)
+              | GITOD         Reg Reg -- src(intreg), dst(fpreg)
+
+	      | GADD	      Size Reg Reg Reg -- src1, src2, dst
+	      | GDIV	      Size Reg Reg Reg -- src1, src2, dst
+	      | GSUB	      Size Reg Reg Reg -- src1, src2, dst
+	      | GMUL	      Size Reg Reg Reg -- src1, src2, dst
+
+    	      | GCMP	      Size Reg Reg -- src1, src2
+
+     	      | GABS	      Size Reg Reg -- src, dst
+    	      | GNEG	      Size Reg Reg -- src, dst
+    	      | GSQRT	      Size Reg Reg -- src, dst
 
 -- Comparison
 
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index f5e02cb854..7bafa78a52 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -46,7 +46,7 @@ module MachRegs (
 #endif
 #if i386_TARGET_ARCH
 	, eax, ebx, ecx, edx, esi, esp
-	, st0, st1, st2, st3, st4, st5, st6, st7
+	, fake0, fake1, fake2, fake3, fake4, fake5
 #endif
 #if sparc_TARGET_ARCH
 	, allArgRegs
@@ -370,7 +370,10 @@ Intel x86 architecture:
 - Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
 - Registers 0-7 have 16-bit counterparts (ax, bx etc.)
 - Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-- Registers 8-15 hold extended floating point values.
+- Registers 8-13 are fakes; we pretend x86 has 6 conventionally-addressable
+  fp registers, and 3-operand insns for them, and we translate this into
+  real stack-based x86 fp code after register allocation.
+
 \begin{code}
 #if i386_TARGET_ARCH
 
@@ -378,7 +381,7 @@ gReg,fReg :: Int -> Int
 gReg x = x
 fReg x = (8 + x)
 
-st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
+fake0, fake1, fake2, fake3, fake4, fake5, eax, ebx, ecx, edx, esp :: Reg
 eax = realReg (gReg 0)
 ebx = realReg (gReg 1)
 ecx = realReg (gReg 2)
@@ -387,15 +390,12 @@ esi = realReg (gReg 4)
 edi = realReg (gReg 5)
 ebp = realReg (gReg 6)
 esp = realReg (gReg 7)
-st0 = realReg (fReg 0)
-st1 = realReg (fReg 1)
-st2 = realReg (fReg 2)
-st3 = realReg (fReg 3)
-st4 = realReg (fReg 4)
-st5 = realReg (fReg 5)
-st6 = realReg (fReg 6)
-st7 = realReg (fReg 7)
-
+fake0 = realReg (fReg 0)
+fake1 = realReg (fReg 1)
+fake2 = realReg (fReg 2)
+fake3 = realReg (fReg 3)
+fake4 = realReg (fReg 4)
+fake5 = realReg (fReg 5)
 #endif
 \end{code}
 
@@ -474,14 +474,12 @@ names in the header files.  Gag me with a spoon, eh?
 #define edi 5
 #define ebp 6
 #define esp 7
-#define st0 8
-#define st1 9
-#define st2 10
-#define st3 11
-#define st4 12
-#define st5 13
-#define st6 14
-#define st7 15
+#define fake0 8
+#define fake1 9
+#define fake2 10
+#define fake3 11
+#define fake4 12
+#define fake5 13
 #endif
 #if sparc_TARGET_ARCH
 #define g0 0
@@ -765,7 +763,7 @@ reservedRegs
 freeRegs :: [Reg]
 freeRegs
   = freeMappedRegs IF_ARCH_alpha( [0..63],
-		   IF_ARCH_i386(  [0..15],
+		   IF_ARCH_i386(  [0..13],
 		   IF_ARCH_sparc( [0..63],)))
 
 -------------------------------
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 304a4a2de4..eddbe80d8f 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -94,14 +94,14 @@ pprReg IF_ARCH_i386(s,) r
 	_ -> SLIT("very naughty I386 byte register")
       })
 
-    {- UNUSED:
+{- UNUSED:
     ppr_reg_no HB i = ptext
       (case i of {
 	ILIT( 0) -> SLIT("%ah");  ILIT( 1) -> SLIT("%bh");
 	ILIT( 2) -> SLIT("%ch");  ILIT( 3) -> SLIT("%dh");
 	_ -> SLIT("very naughty I386 high byte register")
       })
-    -}
+-}
 
 {- UNUSED:
     ppr_reg_no S i = ptext
@@ -125,21 +125,17 @@ pprReg IF_ARCH_i386(s,) r
 
     ppr_reg_no F i = ptext
       (case i of {
-	--ToDo: rm these (???)
-	ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
-	ILIT(10) -> SLIT("%st(2)");  ILIT(11) -> SLIT("%st(3)");
-	ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
-	ILIT(14) -> SLIT("%st(6)");  ILIT(15) -> SLIT("%st(7)");
+	ILIT( 8) -> SLIT("%fake0");  ILIT( 9) -> SLIT("%fake1");
+	ILIT(10) -> SLIT("%fake2");  ILIT(11) -> SLIT("%fake3");
+	ILIT(12) -> SLIT("%fake4");  ILIT(13) -> SLIT("%fake5");
 	_ -> SLIT("very naughty I386 float register")
       })
 
     ppr_reg_no DF i = ptext
       (case i of {
-	--ToDo: rm these (???)
-	ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
-	ILIT(10) -> SLIT("%st(2)");  ILIT(11) -> SLIT("%st(3)");
-	ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
-	ILIT(14) -> SLIT("%st(6)");  ILIT(15) -> SLIT("%st(7)");
+	ILIT( 8) -> SLIT("%fake0");  ILIT( 9) -> SLIT("%fake1");
+	ILIT(10) -> SLIT("%fake2");  ILIT(11) -> SLIT("%fake3");
+	ILIT(12) -> SLIT("%fake4");  ILIT(13) -> SLIT("%fake5");
 	_ -> SLIT("very naughty I386 float register")
       })
 #endif
@@ -405,7 +401,7 @@ pprInstr (SEGMENT TextSegment)
     = ptext
 	 IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
 	,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
-	,IF_ARCH_i386(SLIT(".text\n\t.align 4") {-needs per-OS variation!-}
+	,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-}
 	,)))
 
 pprInstr (SEGMENT DataSegment)
@@ -998,70 +994,111 @@ pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
 
 pprInstr (CALL imm)
-  = hcat [ ptext SLIT("\tcall "), pprImm imm ]
-
-pprInstr SAHF = ptext SLIT("\tsahf")
-pprInstr FABS = ptext SLIT("\tfabs")
-
-pprInstr (FADD sz src@(OpAddr _))
-  = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src]
-pprInstr (FADD sz src)
-  = ptext SLIT("\tfadd")
-pprInstr FADDP
-  = ptext SLIT("\tfaddp")
-pprInstr (FMUL sz src)
-  = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src]
-pprInstr FMULP
-  = ptext SLIT("\tfmulp")
-pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op
-pprInstr FCHS = ptext SLIT("\tfchs")
-pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op
-pprInstr FCOS = ptext SLIT("\tfcos")
-pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op
-pprInstr (FDIV sz src)
-  = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src]
-pprInstr FDIVP
-  = ptext SLIT("\tfdivp")
-pprInstr (FDIVR sz src)
-  = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src]
-pprInstr FDIVRP
-  = ptext SLIT("\tfdivpr")
-pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op
-pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op
-pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg
-pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op
-pprInstr (FLD sz (OpImm (ImmCLbl src)))
-  = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src]
-pprInstr (FLD sz src)
-  = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src]
-pprInstr FLD1 = ptext SLIT("\tfld1")
-pprInstr FLDZ = ptext SLIT("\tfldz")
-pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op
-pprInstr FRNDINT = ptext SLIT("\tfrndint")
-pprInstr FSIN = ptext SLIT("\tfsin")
-pprInstr FSQRT = ptext SLIT("\tfsqrt")
-pprInstr (FST sz dst)
-  = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst]
-pprInstr (FSTP sz dst)
-  = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst]
-pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op
-pprInstr (FSUB sz src)
-  = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src]
-pprInstr FSUBP
-  = ptext SLIT("\tfsubp")
-pprInstr (FSUBR size src)
-  = pprSizeOp SLIT("fsubr") size src
-pprInstr FSUBRP
-  = ptext SLIT("\tfsubpr")
-pprInstr (FISUBR size op)
-  = pprSizeAddr SLIT("fisubr") size op
-pprInstr FTST = ptext SLIT("\tftst")
-pprInstr (FCOMP sz op)
-  = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op]
-pprInstr FUCOMPP = ptext SLIT("\tfucompp")
-pprInstr FXCH = ptext SLIT("\tfxch")
-pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax")
-pprInstr FNOP = ptext SLIT("")
+   = hcat [ ptext SLIT("\tffree %st(0) ; call "), pprImm imm ]
+
+
+-- Simulating a flat register set on the x86 FP stack is tricky.
+-- you have to free %st(7) before pushing anything on the FP reg stack
+-- so as to preclude the possibility of a FP stack overflow exception.
+-- ToDo: make gpop into a single instruction, FST
+pprInstr g@(GMOV src dst) 
+   = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
+
+-- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FXCH (dst+1) ; FINCSTP
+pprInstr g@(GLD sz addr dst)
+ = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp, 
+                 pprAddr addr, gsemi, gpop dst 1])
+
+-- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
+pprInstr g@(GST sz src addr)
+ = pprG g (hcat [gtab, gpush src 0, gsemi, 
+                 text "fstp", pprSize sz, gsp, pprAddr addr])
+
+pprInstr g@(GFTOD src dst) 
+   = pprG g bogus
+pprInstr g@(GFTOI src dst) 
+   = pprG g bogus
+
+pprInstr g@(GDTOF src dst) 
+   = pprG g bogus
+pprInstr g@(GDTOI src dst) 
+   = pprG g bogus
+
+pprInstr g@(GITOF src dst) 
+   = pprG g bogus
+pprInstr g@(GITOD src dst) 
+   = pprG g bogus
+
+pprInstr g@(GCMP sz src1 src2) 
+   = pprG g (hcat [gtab, text "pushl %eax ; ",
+                   gpush src2 0, gsemi, gpush src1 1]
+             $$
+             hcat [gtab, text "fcompp ; fstsw %ax ; sahf ; popl %eax"])
+
+pprInstr g@(GABS sz src dst)
+   = pprG g bogus
+pprInstr g@(GNEG sz src dst)
+   = pprG g bogus
+pprInstr g@(GSQRT sz src dst)
+   = pprG g bogus
+
+pprInstr g@(GADD sz src1 src2 dst)
+   = pprG g (hcat [gtab, gpush src1 0, 
+                   text " ; fadd ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+pprInstr g@(GSUB sz src1 src2 dst)
+   = pprG g (hcat [gtab, gpush src1 0, 
+                   text " ; fsub ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+pprInstr g@(GMUL sz src1 src2 dst)
+   = pprG g (hcat [gtab, gpush src1 0, 
+                   text " ; fmul ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+pprInstr g@(GDIV sz src1 src2 dst)
+   = pprG g (hcat [gtab, gpush src1 0, 
+                   text " ; fdiv ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+
+--------------------------
+gpush reg offset
+   = hcat [text "ffree %st(7) ; fld ", greg reg offset]
+gpop reg offset
+   = hcat [text "fxch ", greg reg offset, gsemi, text "fincstp"]
+
+bogus = text "\tbogus"
+greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
+gsemi = text " ; "
+gtab  = char '\t'
+gsp   = char ' '
+gregno (FixedReg i) = I# i
+gregno (MappedReg i) = I# i
+
+pprG :: Instr -> SDoc -> SDoc
+pprG fake actual
+   = (char '#' <> pprGInstr fake) $$ actual
+
+pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") DF src dst
+pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
+pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
+
+pprGInstr (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst
+pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L  src dst
+
+pprGInstr (GDTOF src dst) = pprSizeSizeRegReg SLIT("gdtof") DF F src dst
+pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
+
+pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F  src dst
+pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
+
+pprGInstr (GCMP sz src dst) = pprSizeRegReg SLIT("gcmp") sz src dst
+pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
+pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
+pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
+
+pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
+pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
+pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
+pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
 \end{code}
 
 Continue with I386-only printing bits and bobs:
@@ -1121,6 +1158,45 @@ pprSizeOpReg name size op1 reg
 	pprReg size reg
     ]
 
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc
+pprSizeRegReg name size reg1 reg2
+  = hcat [
+    	char '\t',
+	ptext name,
+    	pprSize size,
+	space,
+	pprReg size reg1,
+        comma,
+        pprReg size reg2
+    ]
+
+pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> SDoc
+pprSizeSizeRegReg name size1 size2 reg1 reg2
+  = hcat [
+    	char '\t',
+	ptext name,
+    	pprSize size1,
+        pprSize size2,
+	space,
+	pprReg size1 reg1,
+        comma,
+        pprReg size2 reg2
+    ]
+
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc
+pprSizeRegRegReg name size reg1 reg2 reg3
+  = hcat [
+    	char '\t',
+	ptext name,
+    	pprSize size,
+	space,
+	pprReg size reg1,
+        comma,
+        pprReg size reg2,
+        comma,
+        pprReg size reg3
+    ]
+
 pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc
 pprSizeAddr name size op
   = hcat [
@@ -1143,6 +1219,18 @@ pprSizeAddrReg name size op dst
 	pprReg size dst
     ]
 
+pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> SDoc
+pprSizeRegAddr name size src op
+  = hcat [
+    	char '\t',
+	ptext name,
+    	pprSize size,
+	space,
+	pprReg size src,
+	comma,
+	pprAddr op
+    ]
+
 pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
 pprOpOp name size op1 op2
   = hcat [
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 811a39a0ee..e3965e8af3 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -64,6 +64,7 @@ import OrdList		( mkUnitList )
 import PrimRep		( PrimRep(..) )
 import UniqSet		-- quite a bit of it
 import Outputable
+import PprMach		( pprInstr )
 \end{code}
 
 %************************************************************************
@@ -379,48 +380,36 @@ regUsage instr = case instr of
     CALL imm		-> usage [] callClobberedRegs
     CLTD		-> usage [eax] [edx]
     NOP			-> usage [] []
-    SAHF 		-> usage [eax] []
-    FABS 		-> usage [st0] [st0]
-    FADD sz src		-> usage (st0:opToReg src) [st0] -- allFPRegs
-    FADDP 		-> usage [st0,st1] [st0] -- allFPRegs
-    FIADD sz asrc	-> usage (addrToRegs asrc) [st0]
-    FCHS 		-> usage [st0] [st0]
-    FCOM sz src		-> usage (st0:opToReg src) []
-    FCOS 		-> usage [st0] [st0]
-    FDIV sz src 	-> usage (st0:opToReg src) [st0]
-    FDIVP  		-> usage [st0,st1] [st0]
-    FDIVRP 		-> usage [st0,st1] [st0]
-    FIDIV sz asrc	-> usage (addrToRegs asrc) [st0]
-    FDIVR sz src 	-> usage (st0:opToReg src) [st0]
-    FIDIVR sz asrc	-> usage (addrToRegs asrc) [st0]
-    FICOM sz asrc	-> usage (addrToRegs asrc) []
-    FILD sz asrc dst	-> usage (addrToRegs asrc) [dst] -- allFPRegs
-    FIST sz adst	-> usage (st0:addrToRegs adst) []
-    FLD	 sz src 	-> usage (opToReg src) [st0] -- allFPRegs
-    FLD1 		-> usage [] [st0] -- allFPRegs
-    FLDZ 		-> usage [] [st0] -- allFPRegs
-    FMUL sz src 	-> usage (st0:opToReg src) [st0]
-    FMULP 	 	-> usage [st0,st1] [st0]
-    FIMUL sz asrc	-> usage (addrToRegs asrc) [st0]
-    FRNDINT 		-> usage [st0] [st0]
-    FSIN 		-> usage [st0] [st0]
-    FSQRT 		-> usage [st0] [st0]
-    FST sz (OpReg r)	-> usage [st0] [r]
-    FST sz dst		-> usage (st0:opToReg dst) []
-    FSTP sz (OpReg r)	-> usage [st0] [r] -- allFPRegs
-    FSTP sz dst		-> usage (st0:opToReg dst) [] -- allFPRegs
-    FSUB sz src		-> usage (st0:opToReg src) [st0] -- allFPRegs
-    FSUBR sz src	-> usage (st0:opToReg src) [st0] -- allFPRegs
-    FISUB sz asrc	-> usage (addrToRegs asrc) [st0]
-    FSUBP 		-> usage [st0,st1] [st0] -- allFPRegs
-    FSUBRP 		-> usage [st0,st1] [st0] -- allFPRegs
-    FISUBR sz asrc	-> usage (addrToRegs asrc) [st0]
-    FTST 		-> usage [st0] []
-    FCOMP sz op		-> usage (st0:opToReg op) [st0] -- allFPRegs
-    FUCOMPP 		-> usage [st0, st1] [st0, st1] --  allFPRegs
-    FXCH		-> usage [st0, st1] [st0, st1]
-    FNSTSW		-> usage [] [eax]
-    _			-> noUsage
+
+    GMOV src dst	-> usage [src] [dst]
+    GLD sz src dst	-> usage (addrToRegs src) [dst]
+    GST sz src dst	-> usage [src] (addrToRegs dst)
+
+    GFTOD src dst	-> usage [src] [dst]
+    GFTOI src dst	-> usage [src] [dst]
+
+    GDTOF src dst	-> usage [src] [dst]
+    GDTOI src dst	-> usage [src] [dst]
+
+    GITOF src dst	-> usage [src] [dst]
+    GITOD src dst	-> usage [src] [dst]
+
+    GADD sz s1 s2 dst	-> usage [s1,s2] [dst]
+    GSUB sz s1 s2 dst	-> usage [s1,s2] [dst]
+    GMUL sz s1 s2 dst	-> usage [s1,s2] [dst]
+    GDIV sz s1 s2 dst	-> usage [s1,s2] [dst]
+
+    GCMP sz src1 src2	-> usage [src1,src2] []
+    GABS sz src dst	-> usage [src] [dst]
+    GNEG sz src dst	-> usage [src] [dst]
+    GSQRT sz src dst	-> usage [src] [dst]
+
+    COMMENT _		-> noUsage
+    SEGMENT _ 		-> noUsage
+    LABEL _		-> noUsage
+    ASCII _ _		-> noUsage
+    DATA _ _		-> noUsage
+    _			-> error ("regUsage: " ++ showSDoc (pprInstr instr)) --noUsage
  where
     usage2 :: Operand -> Operand -> RegUsage
     usage2 op (OpReg reg) = usage (opToReg op) [reg]
@@ -429,10 +418,10 @@ regUsage instr = case instr of
     usage1 :: Operand -> RegUsage
     usage1 (OpReg reg)    = usage [reg] [reg]
     usage1 (OpAddr ea)    = usage (addrToRegs ea) []
-    allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
+    allFPRegs = [fake0,fake1,fake2,fake3,fake4,fake5]
 
     --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
-    callClobberedRegs = [eax]
+    callClobberedRegs = [eax,fake0,fake1,fake2,fake3,fake4,fake5]
 
 -- General purpose register collecting functions.
 
@@ -672,32 +661,39 @@ patchRegs instr env = case instr of
     POP  sz op		-> patch1 (POP  sz) op
     SETCC cond op	-> patch1 (SETCC cond) op
     JMP op		-> patch1 JMP op
-    FADD sz src		-> FADD sz (patchOp src)
-    FIADD sz asrc	-> FIADD sz (lookupAddr asrc)
-    FCOM sz src		-> patch1 (FCOM sz) src
-    FDIV sz src 	-> FDIV sz (patchOp src)
-    --FDIVP sz src 	-> FDIVP sz (patchOp src)
-    FIDIV sz asrc	-> FIDIV sz (lookupAddr asrc)
-    FDIVR sz src 	-> FDIVR sz (patchOp src)
-    --FDIVRP sz src 	-> FDIVRP sz (patchOp src)
-    FIDIVR sz asrc	-> FIDIVR sz (lookupAddr asrc)
-    FICOM sz asrc	-> FICOM sz (lookupAddr asrc)
-    FILD sz asrc dst	-> FILD sz (lookupAddr asrc) (env dst)
-    FIST sz adst	-> FIST sz (lookupAddr adst)
-    FLD	sz src 		-> patch1 (FLD sz) (patchOp src)
-    FMUL sz src 	-> FMUL sz (patchOp src)
-    --FMULP sz src 	-> FMULP sz (patchOp src)
-    FIMUL sz asrc	-> FIMUL sz (lookupAddr asrc)
-    FST sz dst		-> FST sz (patchOp dst)
-    FSTP sz dst		-> FSTP sz (patchOp dst)
-    FSUB sz src		-> FSUB sz (patchOp src)
-    --FSUBP sz src	-> FSUBP sz (patchOp src)
-    FISUB sz asrc	-> FISUB sz (lookupAddr asrc)
-    FSUBR sz src 	-> FSUBR sz (patchOp src)
-    --FSUBRP sz src 	-> FSUBRP sz (patchOp src)
-    FISUBR sz asrc	-> FISUBR sz (lookupAddr asrc)
-    FCOMP sz src	-> FCOMP sz (patchOp src)
-    _			-> instr
+
+    GMOV src dst	-> GMOV (env src) (env dst)
+    GLD sz src dst	-> GLD sz (lookupAddr src) (env dst)
+    GST sz src dst	-> GST sz (env src) (lookupAddr dst)
+
+    GFTOD src dst	-> GFTOD (env src) (env dst)
+    GFTOI src dst	-> GFTOI (env src) (env dst)
+
+    GDTOF src dst	-> GDTOF (env src) (env dst)
+    GDTOI src dst	-> GDTOI (env src) (env dst)
+
+    GITOF src dst	-> GITOF (env src) (env dst)
+    GITOD src dst	-> GITOD (env src) (env dst)
+
+    GADD sz s1 s2 dst	-> GADD sz (env s1) (env s2) (env dst)
+    GSUB sz s1 s2 dst	-> GSUB sz (env s1) (env s2) (env dst)
+    GMUL sz s1 s2 dst	-> GMUL sz (env s1) (env s2) (env dst)
+    GDIV sz s1 s2 dst	-> GDIV sz (env s1) (env s2) (env dst)
+
+    GCMP sz src1 src2	-> GCMP sz (env src1) (env src2)
+    GABS sz src dst	-> GABS sz (env src) (env dst)
+    GNEG sz src dst	-> GNEG sz (env src) (env dst)
+    GSQRT sz src dst	-> GSQRT sz (env src) (env dst)
+
+    COMMENT _		-> instr
+    SEGMENT _ 		-> instr
+    LABEL _		-> instr
+    ASCII _ _		-> instr
+    DATA _ _		-> instr
+    JXX _ _		-> instr
+    CALL _		-> instr
+    CLTD		-> instr
+    _			-> error ("patchInstr: " ++ showSDoc (pprInstr instr)) --instr
   where
     patch1 insn op      = insn (patchOp op)
     patch2 insn src dst = insn (patchOp src) (patchOp dst)
@@ -765,10 +761,15 @@ patchRegs instr env = case instr of
 
 Spill to memory, and load it back...
 
+JRS, 000122: on x86, don't spill directly below the stack pointer, since 
+some insn sequences (int <-> conversions) use this as a temp location.
+Leave 16 bytes of slop.
+
 \begin{code}
 spillReg, loadReg :: Reg -> Reg -> InstrList
 
 spillReg dyn (MemoryReg i pk)
+  | i >= 0  -- JRS paranoia
   = let
 	sz = primRepToSize pk
     in
@@ -777,7 +778,9 @@ spillReg dyn (MemoryReg i pk)
 	 IF_ARCH_alpha( ST sz dyn (spRel i)
 
 	{-I386: spill below stack pointer leaving 2 words/spill-}
-	,IF_ARCH_i386 ( MOV sz (OpReg dyn) (OpAddr (spRel (-2 * i)))
+	,IF_ARCH_i386 ( if pk == FloatRep || pk == DoubleRep
+                        then GST sz dyn (spRel (-16 + (-2 * i)))
+                        else MOV sz (OpReg dyn) (OpAddr (spRel (-16 + (-2 * i))))
 
 	{-SPARC: spill below frame pointer leaving 2 words/spill-}
 	,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i))
@@ -786,12 +789,15 @@ spillReg dyn (MemoryReg i pk)
 
 ----------------------------
 loadReg (MemoryReg i pk) dyn
+  | i >= 0  -- JRS paranoia
   = let
 	sz = primRepToSize pk
     in
     mkUnitList (
 	 IF_ARCH_alpha( LD  sz dyn (spRel i)
-	,IF_ARCH_i386 ( MOV sz (OpAddr (spRel (-2 * i))) (OpReg dyn)
+	,IF_ARCH_i386 ( if   pk == FloatRep || pk == DoubleRep
+                        then GLD sz (spRel (-16 + (-2 * i))) dyn
+                        else MOV sz (OpAddr (spRel (-16 + (-2 * i)))) (OpReg dyn)
 	,IF_ARCH_sparc( LD  sz (fpRel (-2 * i)) dyn
 	,)))
     )
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index c9323ec415..ff5332df1a 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -159,7 +159,7 @@ primCode [] WriteArrayOp [obj, ix, v]
 	obj' = amodeToStix obj
     	ix' = amodeToStix ix
     	v' = amodeToStix v
-    	base = StIndex IntRep obj' arrHS
+    	base = StIndex IntRep obj' arrHS --(StInt (toInteger 3))
     	assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
     in
     returnUs (\xs -> assign : xs)