diff options
| -rw-r--r-- | ghc/compiler/ghci/ByteCodeGen.lhs | 27 | ||||
| -rw-r--r-- | ghc/rts/Interpreter.c | 32 | ||||
| -rw-r--r-- | ghc/rts/Storage.h | 5 |
3 files changed, 42 insertions, 22 deletions
diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index a5b10ca47e..af4e1b96ca 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -354,7 +354,7 @@ mkProtoBCO nm instrs_ordlist origin -- resulting BCO a name. schemeR :: (Id, AnnExpr Id VarSet) -> BcM () schemeR (nm, rhs) -{- + | trace (showSDoc ( (char ' ' $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs @@ -362,11 +362,13 @@ schemeR (nm, rhs) $$ char ' ' ))) False = undefined --} + | otherwise = schemeR_wrk rhs nm (collect [] rhs) +collect xs (_, AnnNote note e) + = collect xs e collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e collect xs not_lambda @@ -374,11 +376,12 @@ collect xs not_lambda schemeR_wrk original_body nm (args, body) = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = fvs ++ reverse args + all_args = reverse args ++ fvs --ORIG: fvs ++ reverse args szsw_args = map taggedIdSizeW all_args szw_args = sum szsw_args p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) - argcheck = {-if null args then nilOL else-} unitOL (ARGCHECK szw_args) + argcheck = --if null args then nilOL else + unitOL (ARGCHECK szw_args) in schemeE szw_args 0 p_init body `thenBc` \ body_code -> emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body)) @@ -477,13 +480,13 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) | isAlgCase - = let binds_r = reverse binds_f - binds_r_szsw = map untaggedIdSizeW binds_r - binds_szw = sum binds_r_szsw - p'' = addListToFM - p' (zip binds_r (mkStackOffsets d' binds_r_szsw)) - d'' = d' + binds_szw - unpack_code = mkUnpackCode 0 0 (map (typePrimRep.idType) binds_f) + = let binds_r = reverse binds_f + binds_r_t_szsw = map taggedIdSizeW binds_r + binds_t_szw = sum binds_r_t_szsw + p'' = addListToFM + p' (zip binds_r (mkStackOffsets d' binds_r_t_szsw)) + d'' = d' + binds_t_szw + unpack_code = mkUnpackCode 0 0 (map (typePrimRep.idType) binds_f) in schemeE d'' s p'' rhs `thenBc` \ rhs_code -> returnBc (my_discr alt, unpack_code `appOL` rhs_code) | otherwise @@ -1160,7 +1163,7 @@ mkLitF f mkLitD d | wORD_SIZE == 4 = runST (do - arr <- newDoubleArray ((0::Int),0) + arr <- newDoubleArray ((0::Int),1) writeDoubleArray arr 0 d d_arr <- castSTUArray arr w0 <- readWordArray d_arr 0 diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index f993feeca3..daf5bb5dae 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.8 $ - * $Date: 2001/01/05 15:24:28 $ + * $Revision: 1.9 $ + * $Date: 2001/01/09 17:36:21 $ * ---------------------------------------------------------------------------*/ #ifdef GHCI @@ -78,6 +78,12 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) fprintf(stderr,"Entering: "); printObj(obj); fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu); fprintf(stderr, "\n" ); + + // checkSanity(1); + // iSp--; StackWord(0) = obj; + // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + // iSp++; + printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); fprintf(stderr, "\n\n"); ); @@ -93,6 +99,9 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) StgAP_UPD *ap = (StgAP_UPD*)obj; Words = ap->n_args; + /* WARNING: do a stack overflow check here ! + This code (copied from stg_AP_UPD_entry) is not correct without it. */ + iSp -= sizeofW(StgUpdateFrame); { @@ -104,7 +113,6 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) iSu = __frame; } - /* WARNING: do a stack overflow check here ! */ iSp -= Words; /* Reload the stack */ @@ -151,6 +159,8 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) } ); + // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + switch (BCO_NEXT) { case bci_ARGCHECK: { @@ -321,6 +331,17 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) bciPtr = failto; goto nextInsn; } + case bci_TESTEQ_I: { + /* The top thing on the stack should be a tagged int. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)StackWord(1); + ASSERT(1 == StackWord(0)); + fprintf(stderr, "TESTEQ_I: discr = %d, stack = %d\n",(I_)BCO_LIT(discr), stackInt); + if (stackInt != (I_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } /* Control-flow ish things */ case bci_ENTER: { @@ -331,14 +352,14 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) compiled code. */ int o_itoc_itbl = BCO_NEXT; int tag = StackWord(0); - StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag+1 +1); + StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1); ASSERT(tag <= 2); /* say ... */ if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1_info /* || ret_itbl == stg_ctoi_ret_F1_info || ret_itbl == stg_ctoi_ret_D1_info */) { /* Returning to interpreted code. Interpret the BCO immediately underneath the itbl. */ - StgBCO* ret_bco = (StgBCO*)StackWord(tag+1 +1+1); + StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1); iSp --; StackWord(0) = (W_)ret_bco; goto nextEnter; @@ -359,7 +380,6 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) /* As yet unimplemented */ case bci_TESTLT_I: - case bci_TESTEQ_I: case bci_TESTLT_F: case bci_TESTEQ_F: case bci_TESTLT_D: diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h index 4ba2731a27..612874ba41 100644 --- a/ghc/rts/Storage.h +++ b/ghc/rts/Storage.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Storage.h,v 1.20 2000/12/19 12:51:58 simonmar Exp $ + * $Id: Storage.h,v 1.21 2001/01/09 17:36:21 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -361,9 +361,6 @@ static __inline__ StgOffset PAP_sizeW ( unsigned int n_args ) static __inline__ StgOffset CONSTR_sizeW( unsigned int p, unsigned int np ) { return sizeofW(StgHeader) + p + np; } -static __inline__ StgOffset BCO_sizeW ( unsigned int p, unsigned int np, unsigned int is ) -{ return sizeofW(StgBCO) + p + np + (is+sizeof(StgWord)-1)/sizeof(StgWord); } - static __inline__ StgOffset THUNK_SELECTOR_sizeW ( void ) { return sizeofW(StgHeader) + MIN_UPD_SIZE; } |