From 7c1668b46ada13fbb5a8de2276b2878ed1c6e210 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 15 Feb 2000 13:16:20 +0000 Subject: [PATCH] [project @ 2000-02-15 13:16:19 by sewardj] Backend interop fixes: -- Make Hugs use the same constructor tag numbering as GHC, viz, starting at zero. -- Evaluator.c: when unwinding the stack on entering a constructor, return to the scheduler if a RET_{VEC_}{SMALL|BIG} is found on the stack. --- ghc/interpreter/hugs.c | 6 ++---- ghc/interpreter/stg.c | 36 ++++++++++++++++++++++-------------- ghc/interpreter/storage.c | 9 +++++---- ghc/interpreter/storage.h | 6 ++++-- ghc/rts/Evaluator.c | 10 ++++++---- ghc/rts/StgCRun.c | 4 ++-- 6 files changed, 41 insertions(+), 30 deletions(-) diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index cd1eff5..75956fe 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.38 $ - * $Date: 2000/02/08 15:32:29 $ + * $Revision: 1.39 $ + * $Date: 2000/02/15 13:16:19 $ * ------------------------------------------------------------------------*/ #include @@ -40,8 +40,6 @@ Bool showInstRes = FALSE; Bool multiInstRes = FALSE; #endif -#define N_PRELUDE_SCRIPTS (combined ? 30 : 1) - /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c index ac620f7..78c60bd 100644 --- a/ghc/interpreter/stg.c +++ b/ghc/interpreter/stg.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: stg.c,v $ - * $Revision: 1.10 $ - * $Date: 1999/12/07 11:14:56 $ + * $Revision: 1.11 $ + * $Date: 2000/02/15 13:16:20 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -25,32 +25,40 @@ * Utility functions * ------------------------------------------------------------------------*/ -void* stgConInfo( StgDiscr d ) +/* Make an info table for a constructor or tuple. */ +void* stgConInfo ( StgDiscr d ) { + int tag; switch (whatIs(d)) { - case NAME: + case NAME: { + tag = cfunOf(d); + if (tag > 0) tag--; if (!name(d).itbl) - name(d).itbl = asmMkInfo(cfunOf(d),name(d).arity); + name(d).itbl = asmMkInfo(tag,name(d).arity); return name(d).itbl; - case TUPLE: + } + case TUPLE: { + tag = 0; if (!tycon(d).itbl) - tycon(d).itbl = asmMkInfo(0,tupleOf(d)); + tycon(d).itbl = asmMkInfo(tag,tupleOf(d)); return tycon(d).itbl; + } default: internal("stgConInfo"); } } -int stgDiscrTag( StgDiscr d ) +/* Return the tag for a constructor or tuple, starting at zero. */ +int stgDiscrTag ( StgDiscr d ) { + int tag; switch (whatIs(d)) { - case NAME: - return cfunOf(d); - case TUPLE: - return 0; - default: - internal("stgDiscrTag"); + case NAME: tag = cfunOf(d); break; + case TUPLE: tag = 0; + default: internal("stgDiscrTag"); } + if (tag > 0) tag--; + return tag; } /* -------------------------------------------------------------------------- diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 39558ff..d6db5f3 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.42 $ - * $Date: 2000/02/08 17:50:46 $ + * $Revision: 1.43 $ + * $Date: 2000/02/15 13:16:20 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1643,12 +1643,13 @@ String f; { /* of status for later restoration */ } Bool isPreludeScript() { /* Test whether this is the Prelude*/ - return (scriptHw==0); + return (scriptHw < N_PRELUDE_SCRIPTS /*==0*/ ); } Bool moduleThisScript(m) /* Test if given module is defined */ Module m; { /* in current script file */ - return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw; + return scriptHw < 1 + || m>=scripts[scriptHw-1].moduleHw; } Module lastModule() { /* Return module in current script file */ diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index df74320..8806d29 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.25 $ - * $Date: 2000/01/11 15:40:57 $ + * $Revision: 1.26 $ + * $Date: 2000/02/15 13:16:20 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -545,6 +545,8 @@ extern void* lookupOExtraTabName ( char* sym ); #define isPrelude(m) (m==modulePrelude) +#define N_PRELUDE_SCRIPTS (combined ? 30 : 1) + /* -------------------------------------------------------------------------- * Type constructor names: * ------------------------------------------------------------------------*/ diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index c123d39..6001b85 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.32 $ - * $Date: 2000/02/14 11:04:58 $ + * $Revision: 1.33 $ + * $Date: 2000/02/15 13:16:20 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -851,7 +851,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { int tag = BCO_INSTR_8; StgWord offset = BCO_INSTR_16; - if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) { + if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) { bciPtr += offset; } Continue; @@ -1448,7 +1448,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) case RET_VEC_SMALL: case RET_BIG: case RET_VEC_BIG: - // barf("todo: RET_[VEC_]{BIG,SMALL}"); + cap->rCurrentTSO->whatNext = ThreadEnterGHC; + xPushCPtr(obj); + RETURN(ThreadYielding); default: belch("entered CONSTR with invalid continuation on stack"); IF_DEBUG(evaluator, diff --git a/ghc/rts/StgCRun.c b/ghc/rts/StgCRun.c index d925fe7..5f732cc 100644 --- a/ghc/rts/StgCRun.c +++ b/ghc/rts/StgCRun.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgCRun.c,v 1.10 2000/02/14 11:01:27 sewardj Exp $ + * $Id: StgCRun.c,v 1.11 2000/02/15 13:16:20 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -38,7 +38,7 @@ static jmp_buf jmp_environment; -#if 1 +#if 0 extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg) { -- 1.7.10.4