From 7385dd9fa7f062997a2860ea13e2c268e0783c40 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 15 Jan 2001 16:55:25 +0000 Subject: [PATCH] [project @ 2001-01-15 16:55:24 by sewardj] In interpreted code, basic support for routing primop calls through to functions in PrelPrimopWrappers.lhs. --- ghc/compiler/absCSyn/Costs.lhs | 4 +-- ghc/compiler/nativeGen/StixPrim.lhs | 3 -- ghc/compiler/prelude/primops.txt | 34 +++++++++--------- ghc/includes/StgMiscClosures.h | 5 +-- ghc/rts/Interpreter.c | 7 ++-- ghc/rts/Linker.c | 3 +- ghc/rts/Printer.c | 9 +++-- ghc/rts/StgMiscClosures.hc | 68 +++++++++++++++++++++++++++-------- 8 files changed, 86 insertions(+), 47 deletions(-) diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 063fe13..32b948d 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 1a699bc..0fcdea2 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 264fec2..73d145e 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 9ccc5dc..e92f4fe 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 cd29189..07c89e2 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 7bfc7c6..d99acf7 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 309edb1..389dd80 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 51b57c3..16d9012 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); \ -- 1.7.10.4