Commit d4993e8b authored by sewardj's avatar sewardj

[project @ 2000-09-11 11:17:09 by sewardj]

Initial primop support for the metacircular interpreter (GHCI).
Only appears if you compile with -DGHCI; if not, the world is
unchanged.

new primops:
   indexPtrOffClosure#
   indexWordOffClosure#

modified:
   dataToTag#   -- now dereferences indirections before extracting tag

new entry code
   mci_constr_entry          and
   mci_constr[1..8]entry
being the direct and vectored return code fragments for interpreter
created constructors.  Support for static constructors is not yet
done.

New handwritten .hc functions:
   mci_make_constr*
being code to create various flavours of constructors from args
on the stack.  An interface file to describe these will follow in
a later commit.
parent 3fc55f79
-----------------------------------------------------------------------
-- $Id: primops.txt,v 1.2 2000/08/21 13:34:06 simonmar Exp $
-- $Id: primops.txt,v 1.3 2000/09/11 11:17:09 sewardj Exp $
--
-- Primitive Operations
--
......@@ -41,6 +41,17 @@ defaults
strictness = { \ arity -> StrictnessInfo (replicate arity wwPrim) False }
usage = { nomangle other }
------------------------------------------------------------------------
--- Support for the metacircular interpreter ---
------------------------------------------------------------------------
primop IndexOffClosureOp_Ptr "indexPtrOffClosure#" GenPrimOp
a -> Int# -> (# b #)
primop IndexOffClosureOp_Word "indexWordOffClosure#" GenPrimOp
a -> Int# -> Word#
------------------------------------------------------------------------
--- Addr# ---
------------------------------------------------------------------------
......
/* -----------------------------------------------------------------------------
* $Id: PrimOps.h,v 1.61 2000/08/21 14:16:57 simonmar Exp $
* $Id: PrimOps.h,v 1.62 2000/09/11 11:17:09 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -10,6 +10,47 @@
#ifndef PRIMOPS_H
#define PRIMOPS_H
/* -----------------------------------------------------------------------------
Helpers for the metacircular interpreter.
-------------------------------------------------------------------------- */
#ifdef GHCI
#define CHASE_INDIRECTIONS(lval) \
do { \
int again; \
do { \
again = 0; \
if (get_itbl((StgClosure*)lval)->type == IND) \
{ again = 1; lval = ((StgInd*)lval)->indirectee; } \
else \
if (get_itbl((StgClosure*)lval)->type == IND_OLDGEN) \
{ again = 1; lval = ((StgIndOldGen*)lval)->indirectee; } \
} while (again); \
} while (0)
#define indexWordOffClosurezh(r,a,i) \
do { StgClosure* tmp = (StgClosure*)(a); \
CHASE_INDIRECTIONS(tmp); \
r = ((W_ *)tmp)[i]; \
} while (0)
#define indexPtrOffClosurezh(r,a,i) \
do { StgClosure* tmp = (StgClosure*)(a); \
CHASE_INDIRECTIONS(tmp); \
r = ((P_ *)tmp)[i]; \
} while (0)
#else
/* These are the original definitions. They don't chase indirections. */
#define indexWordOffClosurezh(r,a,i) r= ((W_ *)(a))[i]
#define indexPtrOffClosurezh(r,a,i) r= ((P_ *)(a))[i]
#endif
/* -----------------------------------------------------------------------------
Comparison PrimOps.
-------------------------------------------------------------------------- */
......@@ -888,7 +929,17 @@ EXTFUN_RTS(mkForeignObjzh_fast);
Constructor tags
-------------------------------------------------------------------------- */
#ifdef GHCI
#define dataToTagzh(r,a) \
do { StgClosure* tmp = (StgClosure*)(a); \
CHASE_INDIRECTIONS(tmp); \
r = (GET_TAG(((StgClosure *)tmp)->header.info)); \
} while (0)
#else
/* Original version doesn't chase indirections. */
#define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
#endif
/* tagToEnum# is handled directly by the code generator. */
/* -----------------------------------------------------------------------------
......
/* -----------------------------------------------------------------------------
* $Id: StgMiscClosures.h,v 1.18 2000/08/02 14:13:27 rrt Exp $
* $Id: StgMiscClosures.h,v 1.19 2000/09/11 11:17:09 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -53,6 +53,20 @@ STGFUN(MUT_CONS_entry);
STGFUN(END_MUT_LIST_entry);
STGFUN(dummy_ret_entry);
#ifdef GHCI
/* entry code for constructors created by the metacircular interpreter */
STGFUN(mci_constr_entry);
STGFUN(mci_constr1_entry);
STGFUN(mci_constr2_entry);
STGFUN(mci_constr3_entry);
STGFUN(mci_constr4_entry);
STGFUN(mci_constr5_entry);
STGFUN(mci_constr6_entry);
STGFUN(mci_constr7_entry);
STGFUN(mci_constr8_entry);
EI_(PrelBase_Izh_con_info); /* Kludge! */
#endif
/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
#define END_TSO_QUEUE ((StgTSO *)(void*)&END_TSO_QUEUE_closure)
#if defined(PAR) || defined(GRAN)
......
......@@ -338,6 +338,9 @@ __export PrelGHC
eqStableNamezh
stableNameToIntzh
indexPtrOffClosurezh
indexWordOffClosurezh
reallyUnsafePtrEqualityzh
unsafeCoercezh
......
/* -----------------------------------------------------------------------------
* $Id: StgMiscClosures.hc,v 1.47 2000/08/02 14:13:28 rrt Exp $
* $Id: StgMiscClosures.hc,v 1.48 2000/09/11 11:17:09 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
......@@ -45,6 +45,258 @@ STGFUN(type##_entry) \
FE_ \
}
/* -----------------------------------------------------------------------------
Support for the metacircular interpreter.
-------------------------------------------------------------------------- */
#ifdef GHCI
/* 9 bits of return code for constructors created by mci_make_constr. */
FN_(mci_constr_entry)
{
/* R1 points at the constructor */
FB_
STGCALL2(fprintf,stderr,"mci_constr_entry (direct return)!\n");
/* Pointless, since SET_TAG doesn't do anything */
SET_TAG( GET_TAG(GET_INFO(R1.cl)));
JMP_(ENTRY_CODE((P_)(*Sp)));
FE_
}
FN_(mci_constr1_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),0)); FE_ }
FN_(mci_constr2_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),1)); FE_ }
FN_(mci_constr3_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),2)); FE_ }
FN_(mci_constr4_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),3)); FE_ }
FN_(mci_constr5_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),4)); FE_ }
FN_(mci_constr6_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),5)); FE_ }
FN_(mci_constr7_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),6)); FE_ }
FN_(mci_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
/* Since this stuff is ostensibly in some other module, we need
to supply an __init_ function.
*/
START_MOD_INIT(__init_MCIzumakezuconstr)
END_MOD_INIT()
INFO_TABLE(mci_make_constr_info, mci_make_constr_entry, 0,0,FUN_STATIC,,EF_,0,0);
INFO_TABLE(mci_make_constrI_info, mci_make_constrI_entry, 0,0,FUN_STATIC,,EF_,0,0);
INFO_TABLE(mci_make_constrP_info, mci_make_constrP_entry, 0,0,FUN_STATIC,,EF_,0,0);
INFO_TABLE(mci_make_constrPP_info, mci_make_constrPP_entry, 0,0,FUN_STATIC,,EF_,0,0);
INFO_TABLE(mci_make_constrPPP_info,mci_make_constrPPP_entry,0,0,FUN_STATIC,,EF_,0,0);
SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstr_closure,
mci_make_constr_info,0,,EI_)
,{ /* payload */ }
};
SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrI_closure,
mci_make_constrI_info,0,,EI_)
,{ /* payload */ }
};
SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrP_closure,
mci_make_constrP_info,0,,EI_)
,{ /* payload */ }
};
SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrPP_closure,
mci_make_constrPP_info,0,,EI_)
,{ /* payload */ }
};
SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrPPP_closure,
mci_make_constrPPP_info,0,,EI_)
,{ /* payload */ }
};
/* Make a constructor with no args. */
STGFUN(mci_make_constr_entry)
{
nat size, np, nw;
StgClosure* con;
StgInfoTable* itbl;
FB_
/* Sp[0 & 1] are tag, Addr#
*/
itbl = ((StgInfoTable**)Sp)[1];
np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs;
nw = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs;
size = sizeofW(StgHeader) + stg_max(MIN_NONUPD_SIZE, np+nw);
/* STGCALL5(fprintf,stderr,"np %d nw %d size %d\n",np,nw,size); */
/* The total number of words to copy off the stack is np + nw.
That doesn't include tag words, tho.
*/
HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, );
TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,size); /* ccs prof */
con = (StgClosure*)(Hp + 1 - size);
SET_HDR(con, itbl,CCCS);
Sp = Sp +2; /* Zap the Addr# arg */
R1.cl = con;
JMP_(ENTRY_CODE(GET_INFO(R1.cl)));
FE_
}
/* Make a constructor with 1 Int# arg */
STGFUN(mci_make_constrI_entry)
{
nat size, np, nw;
StgClosure* con;
StgInfoTable* itbl;
FB_
/* Sp[0 & 1] are tag, Addr#
Sp[2 & 3] are tag, Int#
*/
itbl = ((StgInfoTable**)Sp)[1];
np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs;
nw = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs;
size = sizeofW(StgHeader) + stg_max(MIN_NONUPD_SIZE, np+nw);
/* STGCALL5(fprintf,stderr,"np %d nw %d size %d\n",np,nw,size); */
/* The total number of words to copy off the stack is np + nw.
That doesn't include tag words, tho.
*/
HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, );
TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,size); /* ccs prof */
con = (StgClosure*)(Hp + 1 - size);
SET_HDR(con, itbl,CCCS);
con->payload[0] = ((StgClosure**)Sp)[3];
Sp = Sp +1/*word*/ +1/*tag*/; /* Zap the Int# arg */
Sp = Sp +2; /* Zap the Addr# arg */
R1.cl = con;
JMP_(ENTRY_CODE(GET_INFO(R1.cl)));
FE_
}
STGFUN(mci_make_constrP_entry)
{
FB_
DUMP_ERRMSG("mci_make_constrP_entry: unimplemented!\n");
STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);
return 0;
FE_
}
/* Make a constructor with 2 pointer args. */
STGFUN(mci_make_constrPP_entry)
{
nat size, np, nw;
StgClosure* con;
StgInfoTable* itbl;
FB_
/* Sp[0 & 1] are tag, Addr#
Sp[2] first arg
Sp[3] second arg
*/
itbl = ((StgInfoTable**)Sp)[1];
np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs;
nw = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs;
size = sizeofW(StgHeader) + stg_max(MIN_NONUPD_SIZE, np+nw);
/* STGCALL5(fprintf,stderr,"np %d nw %d size %d\n",np,nw,size); */
/* The total number of words to copy off the stack is np + nw.
That doesn't include tag words, tho.
*/
HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, );
TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,size); /* ccs prof */
con = (StgClosure*)(Hp + 1 - size);
SET_HDR(con, itbl,CCCS);
con->payload[0] = ((StgClosure**)Sp)[2];
con->payload[1] = ((StgClosure**)Sp)[3];
Sp = Sp +2; /* Zap 2 ptr args */
Sp = Sp +2; /* Zap the Addr# arg */
R1.cl = con;
JMP_(ENTRY_CODE(GET_INFO(R1.cl)));
FE_
}
STGFUN(mci_make_constrPPP_entry)
{
FB_
DUMP_ERRMSG("mci_make_constrPPP_entry: unimplemented!\n");
STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);
return 0;
FE_
}
#if 0
/* It would be nice if this worked, but it doesn't. Yet. */
STGFUN(mci_make_constr_entry)
{
nat size, np, nw_heap, nw_really, w;
StgClosure* con;
StgInfoTable* itbl;
W_* r;
FB_
itbl = ((StgInfoTable**)Sp)[0];
STGCALL3(fprintf,stderr,"mmc: itbl = %d\n",itbl);
STGCALL3(fprintf,stderr,"mmc: sp-4 = %d\n", ((W_*)Sp)[-4] );
STGCALL3(fprintf,stderr,"mmc: sp-3 = %d\n", ((W_*)Sp)[-3] );
STGCALL3(fprintf,stderr,"mmc: sp-2 = %d\n", ((W_*)Sp)[-2] );
STGCALL3(fprintf,stderr,"mmc: sp-1 = %d\n", ((W_*)Sp)[-1] );
STGCALL3(fprintf,stderr,"mmc: sp+0 = %d\n", ((W_*)Sp)[0] );
STGCALL3(fprintf,stderr,"mmc: sp+1 = %d\n", ((W_*)Sp)[1] );
STGCALL3(fprintf,stderr,"mmc: sp+2 = %d\n", ((W_*)Sp)[2] );
STGCALL3(fprintf,stderr,"mmc: sp+3 = %d\n", ((W_*)Sp)[3] );
STGCALL3(fprintf,stderr,"mmc: sp+4 = %d\n", ((W_*)Sp)[4] );
np = itbl->layout.payload.ptrs;
nw_really = itbl->layout.payload.nptrs;
nw_heap = stg_max(nw_really, MIN_NONUPD_SIZE-np);
size = CONSTR_sizeW( np, nw_heap );
/* The total number of words to copy off the stack is np + nw.
That doesn't include tag words, tho.
*/
HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, );
TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,size); /* ccs prof */
con = (StgClosure*)(Hp + 1 - size);
SET_HDR(con, itbl,CCCS);
/* Copy into the closure. */
w = 0;
r = Sp+1;
while (1) {
if (w == np + nw) break;
ASSERT(w < np + nw);
if (IS_ARG_TAG(*r)) {
nat n = *r++;
for (; n > 0; n--)
con->payload[w++] = (StgClosure*)(*r++);
} else {
con->payload[w++] = (StgClosure*)(*r++);
}
ASSERT((P_)r <= (P_)Su);
}
/* Remove all the args we've used. */
Sp = r;
R1.cl = con;
JMP_(ENTRY_CODE(R1.cl));
FE_
}
#endif
#endif /* GHCI */
/* -----------------------------------------------------------------------------
Entry code for an indirection.
-------------------------------------------------------------------------- */
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment