[project @ 2000-01-26 13:40:54 by sewardj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / PprMach.lhs

diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index eddbe80..7f72f4d 100644 (file)
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -477,12 +477,25 @@ pprInstr (DATA s xs)
   = vcat (concatMap (ppr_item s) xs)
     where
 #if alpha_TARGET_ARCH
+            ppr_item = error "ppr_item on Alpha"
+#if 0
             This needs to be fixed.
            B  -> SLIT("\t.byte\t")
            BU -> SLIT("\t.byte\t")
            Q  -> SLIT("\t.quad\t")
            TF -> SLIT("\t.t_floating\t")
 #endif
+#endif
+#if sparc_TARGET_ARCH
+            ppr_item = error "ppr_item on Sparc"
+#if 0
+            This needs to be fixed.
+           B  -> SLIT("\t.byte\t")
+           BU -> SLIT("\t.byte\t")
+           W  -> SLIT("\t.word\t")
+           DF -> SLIT("\t.double\t")
+#endif
+#endif
 #if i386_TARGET_ARCH
        ppr_item B  x = [text "\t.byte\t" <> pprImm x]
        ppr_item L  x = [text "\t.long\t" <> pprImm x]
@@ -522,13 +535,6 @@ pprInstr (DATA s xs)
              )
 
 #endif
-#if sparc_TARGET_ARCH
-            This needs to be fixed.
-           B  -> SLIT("\t.byte\t")
-           BU -> SLIT("\t.byte\t")
-           W  -> SLIT("\t.word\t")
-           DF -> SLIT("\t.double\t")
-#endif
 
 -- fall through to rest of (machine-specific) pprInstr...
 \end{code}
@@ -992,19 +998,20 @@ pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
 
 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-
 pprInstr (CALL imm)
-   = hcat [ ptext SLIT("\tffree %st(0) ; call "), pprImm imm ]
+   = (<>) (ptext SLIT("\tcall ")) (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) 
+pprInstr g@(GMOV src dst)
+   | src == dst
+   = empty
+   | otherwise 
    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
 
--- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FXCH (dst+1) ; FINCSTP
+-- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
 pprInstr g@(GLD sz addr dst)
  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp, 
                  pprAddr addr, gsemi, gpop dst 1])
@@ -1036,11 +1043,11 @@ pprInstr g@(GCMP sz src1 src2)
              hcat [gtab, text "fcompp ; fstsw %ax ; sahf ; popl %eax"])
 
 pprInstr g@(GABS sz src dst)
-   = pprG g bogus
+   = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
 pprInstr g@(GNEG sz src dst)
-   = pprG g bogus
+   = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
 pprInstr g@(GSQRT sz src dst)
-   = pprG g bogus
+   = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt ; ", gpop dst 1])
 
 pprInstr g@(GADD sz src1 src2 dst)
    = pprG g (hcat [gtab, gpush src1 0, 
@@ -1059,11 +1066,16 @@ pprInstr g@(GDIV sz src1 src2 dst)
                    text " ; fdiv ", greg src2 1, text ",%st(0)",
                    gsemi, gpop dst 1])
 
+pprInstr GFREE 
+   = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
+            ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)") 
+          ]
+
 --------------------------
 gpush reg offset
    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
 gpop reg offset
-   = hcat [text "fxch ", greg reg offset, gsemi, text "fincstp"]
+   = hcat [text "fstp ", greg reg offset]
 
 bogus = text "\tbogus"
 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'