[project @ 2001-01-15 16:55:24 by sewardj]

In interpreted code, basic support for routing primop calls through
to functions in PrelPrimopWrappers.lhs.

8 files changed, 86 insertions, 47 deletions

diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs
index 063fe130d8..32b948d3b7 100644
--- a/ghc/compiler/absCSyn/Costs.lhs
+++ b/ghc/compiler/absCSyn/Costs.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: Costs.lhs,v 1.27 2000/10/24 07:35:00 simonpj Exp $
+% $Id: Costs.lhs,v 1.28 2001/01/15 16:55:24 sewardj Exp $
 %
 % Only needed in a GranSim setup -- HWL
 % ---------------------------------------------------------------------------
@@ -358,7 +358,7 @@ floatOps =
 gmpOps :: [PrimOp]
 gmpOps	=
   [   IntegerAddOp , IntegerSubOp , IntegerMulOp
-    , IntegerQuotRemOp , IntegerDivModOp , IntegerNegOp
+    , IntegerQuotRemOp , IntegerDivModOp
     , IntegerCmpOp
     , Integer2IntOp  , Int2IntegerOp
   ]
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 1a699bc3aa..0fcdea207c 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -55,9 +55,6 @@ and modify our heap check accordingly.
 \begin{code}
 -- NB: ordering of clauses somewhere driven by
 -- the desire to getting sane patt-matching behavior
-primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
-  = gmpNegate (sr,dr) (sa,da)
-
 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
   = gmpCompare res (sa1,da1, sa2,da2)
 
diff --git a/ghc/compiler/prelude/primops.txt b/ghc/compiler/prelude/primops.txt
index 264fec2511..73d145ec39 100644
--- a/ghc/compiler/prelude/primops.txt
+++ b/ghc/compiler/prelude/primops.txt
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------
--- $Id: primops.txt,v 1.14 2001/01/15 09:55:41 sewardj Exp $
+-- $Id: primops.txt,v 1.15 2001/01/15 16:55:24 sewardj Exp $
 --
 -- Primitive Operations
 --
@@ -362,9 +362,6 @@ primop   Int64ToIntegerOp   "int64ToInteger#" GenPrimOp
 --- Integer#                                                         ---
 ------------------------------------------------------------------------
 
-primop   IntegerNegOp   "negateInteger#" GenPrimOp    
-   Int# -> ByteArr# -> (# Int#, ByteArr# #)
-
 primop   IntegerAddOp   "plusInteger#" GenPrimOp   
    Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #)
    with commutable = True
@@ -772,9 +769,6 @@ primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp
 primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp
    Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #)
 
-primop ReadOffAddrOp_ForeignObj "readForeignObjOffAddr#" GenPrimOp
-   Addr# -> Int# -> State# s -> (# State# s, ForeignObj# #)
-
 primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp
    Addr# -> Int# -> State# s -> (# State# s, Int# #)
 
@@ -1256,17 +1250,21 @@ primop  ParAtForNowOp  "parAtForNow#" GenPrimOp
    usage            = { mangle ParAtForNowOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM }
    has_side_effects = True
 
-primop  CopyableOp  "copyable#" GenPrimOp
-   a -> Int#
-   with
-   usage            = { mangle CopyableOp [mkZ] mkR }
-   has_side_effects = True
-
-primop  NoFollowOp "noFollow#" GenPrimOp
-   a -> Int#
-   with
-   usage            = { mangle NoFollowOp [mkZ] mkR }
-   has_side_effects = True
+-- copyable# and noFollow# have no corresponding entry in
+-- PrelGHC.hi-boot, so I don't know whether they should still
+-- be here or not.  JRS, 15 Jan 01
+--
+--primop  CopyableOp  "copyable#" GenPrimOp
+--   a -> Int#
+--   with
+--   usage            = { mangle CopyableOp [mkZ] mkR }
+--   has_side_effects = True
+--
+--primop  NoFollowOp "noFollow#" GenPrimOp
+--   a -> Int#
+--   with
+--   usage            = { mangle NoFollowOp [mkZ] mkR }
+--   has_side_effects = True
 
 
 ------------------------------------------------------------------------
diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h
index 9ccc5dc3c9..e92f4fe99f 100644
--- a/ghc/includes/StgMiscClosures.h
+++ b/ghc/includes/StgMiscClosures.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.31 2000/12/20 15:26:50 rrt Exp $
+ * $Id: StgMiscClosures.h,v 1.32 2001/01/15 16:55:25 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -69,7 +69,8 @@ STGFUN(stg_interp_constr8_entry);
 
 /* Magic glue code for when compiled code returns a value in R1/F1/D1
    to the interpreter. */
-extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_R1_info;
+extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_R1p_info;
+extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_R1n_info;
 extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_F1_info;
 extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_D1_info;
 
diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c
index cd2918932f..07c89e2a81 100644
--- a/ghc/rts/Interpreter.c
+++ b/ghc/rts/Interpreter.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-2000.
  *
  * $RCSfile: Interpreter.c,v $
- * $Revision: 1.12 $
- * $Date: 2001/01/15 09:55:41 $
+ * $Revision: 1.13 $
+ * $Date: 2001/01/15 16:55:25 $
  * ---------------------------------------------------------------------------*/
 
 #ifdef GHCI
@@ -429,7 +429,8 @@ StgThreadReturnCode interpretBCO ( Capability* cap )
                  int           tag         = StackWord(0);
                  StgInfoTable* ret_itbl    = (StgInfoTable*)StackWord(tag +1);
                  ASSERT(tag <= 2); /* say ... */
-                 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1_info
+                 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
+                     || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info) {
                      /* Returning to interpreted code.  Interpret the BCO 
diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c
index 7bfc7c610d..d99acf7126 100644
--- a/ghc/rts/Linker.c
+++ b/ghc/rts/Linker.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Linker.c,v 1.7 2001/01/10 17:21:18 sewardj Exp $
+ * $Id: Linker.c,v 1.8 2001/01/15 16:55:25 sewardj Exp $
  *
  * (c) The GHC Team, 2000
  *
@@ -138,6 +138,7 @@ static int ocResolve_PEi386     ( ObjectCode* oc );
       SymX(stg_INTLIKE_closure)			\
       SymX(stg_CAF_UNENTERED_entry)		\
       SymX(newCAF)				\
+      SymX(newBCOzh_fast)			\
       SymX(putMVarzh_fast)			\
       SymX(newMVarzh_fast)			\
       SymX(takeMVarzh_fast)			\
diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c
index 309edb1eca..389dd801e8 100644
--- a/ghc/rts/Printer.c
+++ b/ghc/rts/Printer.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.32 2001/01/10 17:21:18 sewardj Exp $
+ * $Id: Printer.c,v 1.33 2001/01/15 16:55:25 sewardj Exp $
  *
  * (c) The GHC Team, 1994-2000.
  *
@@ -385,8 +385,11 @@ StgPtr printStackObj( StgPtr sp )
         StgClosure* c = (StgClosure*)(*sp);
         printPtr((StgPtr)*sp);
 #ifdef GHCI
-        if (c == (StgClosure*)&stg_ctoi_ret_R1_info) {
-           fprintf(stderr, "\t\t\tstg_ctoi_ret_R1_info\n" );
+        if (c == (StgClosure*)&stg_ctoi_ret_R1p_info) {
+           fprintf(stderr, "\t\t\tstg_ctoi_ret_R1p_info\n" );
+	} else
+        if (c == (StgClosure*)&stg_ctoi_ret_R1n_info) {
+           fprintf(stderr, "\t\t\tstg_ctoi_ret_R1n_info\n" );
 	} else
         if (c == (StgClosure*)&stg_ctoi_ret_F1_info) {
            fprintf(stderr, "\t\t\tstg_ctoi_ret_F1_info\n" );
diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc
index 51b57c3ece..16d90121e1 100644
--- a/ghc/rts/StgMiscClosures.hc
+++ b/ghc/rts/StgMiscClosures.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.57 2001/01/10 17:21:18 sewardj Exp $
+ * $Id: StgMiscClosures.hc,v 1.58 2001/01/15 16:55:25 sewardj Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -77,7 +77,7 @@ FN_(stg_interp_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
 /* Some info tables to be used when compiled code returns a value to
    the interpreter, i.e. the interpreter pushes one of these onto the
    stack before entering a value.  What the code does is to
-   impedance-match the compiled return convention (in R1/F1/D1 etc) to
+   impedance-match the compiled return convention (in R1p/R1n/F1/D1 etc) to
    the interpreter's convention (returned value is on top of stack),
    and then cause the scheduler to enter the interpreter.
 
@@ -87,7 +87,7 @@ FN_(stg_interp_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
       ptr to one of these info tables.
  
    The info table code, both direct and vectored, must:
-      * push R1/F1/D1 on the stack
+      * push R1/F1/D1 on the stack, and its tag if necessary
       * push the BCO (so it's now on the stack twice)
       * Yield, ie, go to the scheduler.
 
@@ -108,8 +108,9 @@ FN_(stg_interp_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
    haven't got a good story about that yet.
 */
 
-/* When the returned value is in R1 ... */
-#define STG_CtoI_RET_R1_Template(label) 	\
+/* When the returned value is in R1 and it is a pointer, so doesn't
+   need tagging ... */
+#define STG_CtoI_RET_R1p_Template(label) 	\
    IFN_(label)			        \
    {                                    \
       StgPtr bco;                       \
@@ -123,17 +124,50 @@ FN_(stg_interp_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
       FE_                               \
    }
 
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_0_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_1_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_2_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_3_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_4_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_5_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_6_entry);
-STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_7_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_0_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_1_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_2_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_3_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_4_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_5_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_6_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_7_entry);
+
+VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1p,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
+
+
+
+/* When the returned value is in R1 and it isn't a pointer. */
+#define STG_CtoI_RET_R1n_Template(label) 	\
+   IFN_(label)			        \
+   {                                    \
+      StgPtr bco;                       \
+      FB_				\
+      bco = ((StgPtr*)Sp)[1];           \
+      Sp -= 1;				\
+      ((StgPtr*)Sp)[0] = (StgPtr)R1.i;	\
+      Sp -= 1;                          \
+      ((StgPtr*)Sp)[0] = (StgPtr)1; /* tag */   \
+      Sp -= 1;				\
+      ((StgPtr*)Sp)[0] = bco;		\
+      JMP_(stg_yield_to_interpreter);   \
+      FE_                               \
+   }
+
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_0_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_1_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_2_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_3_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_4_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_5_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_6_entry);
+STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_7_entry);
+
+VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1n,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
+
 
-VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
 
 /* When the returned value is in F1 ... */
 #define STG_CtoI_RET_F1_Template(label) 	\
@@ -144,6 +178,8 @@ VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
       bco = ((StgPtr*)Sp)[1];           \
       Sp -= sizeofW(StgFloat);		\
       ASSIGN_FLT((W_*)Sp, F1);          \
+      Sp -= 1;                          \
+      ((StgPtr*)Sp)[0] = (StgPtr)sizeofW(StgFloat); \
       Sp -= 1;				\
       ((StgPtr*)Sp)[0] = bco;		\
       JMP_(stg_yield_to_interpreter);   \
@@ -172,6 +208,8 @@ VEC_POLY_INFO_TABLE(stg_ctoi_ret_F1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
       bco = ((StgPtr*)Sp)[1];           \
       Sp -= sizeofW(StgDouble);		\
       ASSIGN_DBL((W_*)Sp, D1);          \
+      Sp -= 1;                          \
+      ((StgPtr*)Sp)[0] = (StgPtr)sizeofW(StgDouble); \
       Sp -= 1;				\
       ((StgPtr*)Sp)[0] = bco;		\
       JMP_(stg_yield_to_interpreter);   \