[project @ 2001-08-21 12:56:05 by simonpj]

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

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index f27e603..9117e78 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -19,12 +19,11 @@ import MachRegs
 import OrdList         ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
                          snocOL, consOL, concatOL )
 import AbsCUtils       ( magicIdPrimRep )
-import CallConv                ( CallConv )
+import ForeignCall     ( CCallConv(..) )
 import CLabel          ( isAsmTemp, CLabel, labelDynamic )
 import Maybes          ( maybeToBool, expectJust )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
-import CallConv                ( cCallConv, stdCallConv )
 import Stix            ( getNatLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..), 
                           DestInfo, hasDestInfo,
@@ -399,7 +398,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 
-      other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
+      other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
        where
          fn = case other_op of
                 FloatExpOp    -> SLIT("exp")
@@ -458,7 +457,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       AddrNeOp -> int_NE_code x y
       AddrLtOp -> trivialCode (CMP ULT) x y
       AddrLeOp -> trivialCode (CMP ULE) x y
-
+       
       FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
       FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
       FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
@@ -495,6 +494,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
       DoubleDivOp -> trivialFCode  DoubleRep (FDIV TF) x y
 
+      AddrAddOp  -> trivialCode (ADD Q False) x y
+      AddrSubOp  -> trivialCode (SUB Q False) x y
+      AddrRemOp  -> trivialCode (REM Q True) x y
+
       AndOp  -> trivialCode AND x y
       OrOp   -> trivialCode OR  x y
       XorOp  -> trivialCode XOR x y
@@ -505,8 +508,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
       ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
+      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
   where
     {- ------------------------------------------------------------
        Some bizarre special code for getting condition codes into
@@ -672,7 +675,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Int2DoubleOp -> coerceInt2FP DoubleRep x
 
       other_op ->
-       getRegister (StCall fn cCallConv DoubleRep [x])
+       getRegister (StCall fn CCallConv DoubleRep [x])
        where
        (is_float_op, fn)
          = case primop of
@@ -766,6 +769,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       DoubleMulOp -> trivialFCode DoubleRep GMUL x y
       DoubleDivOp -> trivialFCode DoubleRep GDIV x y
 
+      AddrAddOp -> add_code L x y
+      AddrSubOp -> sub_code L x y
+      AddrRemOp -> trivialCode (IREM L) Nothing x y
+
       AndOp -> let op = AND L in trivialCode op (Just op) x y
       OrOp  -> let op = OR  L in trivialCode op (Just op) x y
       XorOp -> let op = XOR L in trivialCode op (Just op) x y
@@ -781,10 +788,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       ISraOp -> shift_code (SAR L) x y {-False-}
       ISrlOp -> shift_code (SHR L) x y {-False-}
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
                                            [promote x, promote y])
                       where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
+      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
                                            [x, y])
       other
          -> pprPanic "getRegister(x86,dyadic primop)" 
@@ -1027,7 +1034,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
                      then StPrim Float2DoubleOp [x]
                      else x
        in
-       getRegister (StCall fn cCallConv DoubleRep [fixed_x])
+       getRegister (StCall fn CCallConv DoubleRep [fixed_x])
        where
        (is_float_op, fn)
          = case primop of
@@ -1133,6 +1140,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       DoubleMulOp -> trivialFCode DoubleRep FMUL x y
       DoubleDivOp -> trivialFCode DoubleRep FDIV x y
 
+      AddrAddOp -> trivialCode (ADD False False) x y
+      AddrSubOp -> trivialCode (SUB False False) x y
+      AddrRemOp -> imul_div SLIT(".rem")  x y
+
       AndOp -> trivialCode (AND False) x y
       OrOp  -> trivialCode (OR  False) x y
       XorOp -> trivialCode (XOR False) x y
@@ -1143,10 +1154,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       ISraOp -> trivialCode SRA x y
       ISrlOp -> trivialCode SRL x y
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
                                            [promote x, promote y])
                       where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
+      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
                                            [x, y])
 
       other
@@ -1154,7 +1165,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
                      (pprStixTree (StPrim primop [x, y]))
 
   where
-    imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
+    imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
 
 getRegister (StInd pk mem)
   = getAmode mem                   `thenNat` \ amode ->
@@ -2345,7 +2356,7 @@ register allocator.
 \begin{code}
 genCCall
     :: FAST_STRING     -- function to call
-    -> CallConv
+    -> CCallConv
     -> PrimRep         -- type of the result
     -> [StixTree]      -- arguments (of mixed type)
     -> NatM InstrBlock
@@ -2442,9 +2453,12 @@ genCCall fn cconv kind args
        call = toOL (
                   [CALL (fn__2 tot_arg_size)]
                   ++
-                  (if cconv == stdCallConv then [] else 
+                       -- Deallocate parameters after call for ccall;
+                       -- but not for stdcall (callee does it)
+                  (if cconv == StdCallConv then [] else 
                   [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
                   ++
+
                   [DELTA (delta + tot_arg_size)]
                )
     in
@@ -2460,11 +2474,11 @@ genCCall fn cconv kind args
     fn__2 tot_arg_size
        | head fn_u == '.'
        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
-       | otherwise 
+       | otherwise     -- General case
        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
 
     stdcallsize tot_arg_size
-       | cconv == stdCallConv = '@':show tot_arg_size
+       | cconv == StdCallConv = '@':show tot_arg_size
        | otherwise            = ""
 
     arg_size DF = 8