[project @ 2001-01-17 16:46:01 by sewardj]

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

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index df4c2a6..45167b1 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -20,15 +20,15 @@ import OrdList              ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
                          snocOL, consOL, concatOL )
 import AbsCUtils       ( magicIdPrimRep )
 import CallConv                ( CallConv )
-import CLabel          ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
+import CLabel          ( isAsmTemp, CLabel, labelDynamic )
 import Maybes          ( maybeToBool, expectJust )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
-import CallConv                ( cCallConv )
+import CallConv                ( cCallConv, stdCallConv )
 import Stix            ( getNatLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..), 
                           DestInfo, hasDestInfo,
-                          pprStixTree, ppStixReg,
+                          pprStixTree, 
                           NatM, thenNat, returnNat, mapNat, 
                           mapAndUnzipNat, mapAccumLNat,
                           getDeltaNat, setDeltaNat
@@ -262,7 +262,7 @@ getRegister (StString s)
        imm_lbl = ImmCLbl lbl
 
        code dst = toOL [
-           SEGMENT DataSegment,
+           SEGMENT RoDataSegment,
            LABEL lbl,
            ASCII True (_UNPK_ s),
            SEGMENT TextSegment,
@@ -918,8 +918,6 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       FloatNegOp     -> trivialUFCode FloatRep (FNEG F) x
       DoubleNegOp    -> trivialUFCode DoubleRep (FNEG DF) x
 
-      DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
-
       Double2FloatOp -> trivialUFCode FloatRep  (FxTOy DF F) x
       Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
 
@@ -2203,7 +2201,6 @@ genCondJump lbl bool
     let
        code   = condCode condition
        cond   = condName condition
-       target = ImmCLbl lbl
     in
     returnNat (code `snocOL` JXX cond lbl)
 
@@ -2340,11 +2337,14 @@ genCCall fn cconv kind args
     let (sizes, codes) = unzip sizes_n_codes
         tot_arg_size   = sum sizes
        code2          = concatOL codes
-       call = toOL [
-                  CALL fn__2,
-                 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
-                  DELTA (delta + tot_arg_size)
-               ]
+       call = toOL (
+                  [CALL (fn__2 tot_arg_size)]
+                  ++
+                  (if cconv == stdCallConv then [] else 
+                  [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+                  ++
+                  [DELTA (delta + tot_arg_size)]
+               )
     in
     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
     returnNat (code2 `appOL` call)
@@ -2354,9 +2354,16 @@ genCCall fn cconv kind args
     -- internally generated names like '.mul,' which don't get an
     -- underscore prefix
     -- ToDo:needed (WDP 96/03) ???
-    fn__2 = case (_HEAD_ fn) of
-             '.' -> ImmLit (ptext fn)
-             _   -> ImmLab False (ptext fn)
+    fn_u  = _UNPK_ fn
+    fn__2 tot_arg_size
+       | head fn_u == '.'
+       = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+       | otherwise 
+       = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
+
+    stdcallsize tot_arg_size
+       | cconv == stdCallConv = '@':show tot_arg_size
+       | otherwise            = ""
 
     arg_size DF = 8
     arg_size F  = 4