From 7794a5513328199916f5230521b10b874c42f2ed Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 10 Jan 2001 17:21:18 +0000 Subject: [PATCH] [project @ 2001-01-10 17:19:01 by sewardj] Today's interpreter bug fixes: FP stuff, and unpacking constrs onto stack. --- ghc/compiler/ghci/ByteCodeGen.lhs | 78 +++++++++++++++++++----------------- ghc/compiler/ghci/InteractiveUI.hs | 6 ++- ghc/rts/Interpreter.c | 61 ++++++++++++++++++++++------ ghc/rts/Linker.c | 3 +- ghc/rts/Printer.c | 4 +- ghc/rts/StgMiscClosures.hc | 56 ++++++++++++++++++++++++-- 6 files changed, 150 insertions(+), 58 deletions(-) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index af4e1b9..295941f 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -55,7 +55,7 @@ import MArray ( castSTUArray, newAddrArray, writeAddrArray ) import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..), malloc, castPtr, plusPtr, mallocBytes ) -import Addr ( Word, addrToInt, nullAddr, writeCharOffAddr ) +import Addr ( Word, addrToInt, writeCharOffAddr ) import Bits ( Bits(..), shiftR ) import CTypes ( CInt ) @@ -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,7 +362,7 @@ schemeR (nm, rhs) $$ char ' ' ))) False = undefined - +-} | otherwise = schemeR_wrk rhs nm (collect [] rhs) @@ -407,7 +407,7 @@ schemeE d s p e@(fvs, AnnVar v) = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. let (push, szw) = pushAtom True d p (AnnVar v) in returnBc (push -- value onto stack - `snocOL` SLIDE szw (d-s) -- clear to sequel + `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN v_rep) -- go where v_rep = typePrimRep (idType v) @@ -416,8 +416,8 @@ schemeE d s p (fvs, AnnLit literal) = let (push, szw) = pushAtom True d p (AnnLit literal) l_rep = literalPrimRep literal in returnBc (push -- value onto stack - `snocOL` SLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN l_rep) -- go + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN l_rep) -- go schemeE d s p (fvs, AnnLet binds b) = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) @@ -473,6 +473,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) scrut_primrep = typePrimRep (idType bndr) isAlgCase = case scrut_primrep of + CharRep -> False ; AddrRep -> False IntRep -> False ; FloatRep -> False ; DoubleRep -> False PtrRep -> True other -> pprPanic "ByteCodeGen.schemeE" (ppr other) @@ -486,7 +487,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) 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) + 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 @@ -573,31 +574,35 @@ should_args_be_tagged (_, other) = panic "should_args_be_tagged: tail call to non-con, non-var" --- Make code to unpack a constructor onto the stack, adding --- tags for the unboxed bits. Takes the PrimReps of the constructor's --- arguments, and a travelling offset along both the constructor --- (off_h) and the stack (off_s). -mkUnpackCode :: Int -> Int -> [PrimRep] -> BCInstrList -mkUnpackCode off_h off_s [] = nilOL -mkUnpackCode off_h off_s (r:rs) - | isFollowableRep r - = let (rs_ptr, rs_nptr) = span isFollowableRep (r:rs) - ptrs_szw = sum (map untaggedSizeW rs_ptr) - in ASSERT(ptrs_szw == length rs_ptr) - ASSERT(off_h == 0) - ASSERT(off_s == 0) - UNPACK ptrs_szw - `consOL` mkUnpackCode (off_h + ptrs_szw) (off_s + ptrs_szw) rs_nptr - | otherwise - = case r of - IntRep -> approved - FloatRep -> approved - DoubleRep -> approved +-- Make code to unpack the top-of-stack constructor onto the stack, +-- adding tags for the unboxed bits. Takes the PrimReps of the +-- constructor's arguments. off_h and off_s are travelling offsets +-- along the constructor and the stack. +mkUnpackCode :: [PrimRep] -> BCInstrList +mkUnpackCode reps + = all_code where - approved = UPK_TAG usizeW off_h off_s `consOL` theRest - theRest = mkUnpackCode (off_h + usizeW) (off_s + tsizeW) rs - usizeW = untaggedSizeW r - tsizeW = taggedSizeW r + all_code = ptrs_code `appOL` do_nptrs ptrs_szw ptrs_szw reps_nptr + + reps_ptr = filter isFollowableRep reps + reps_nptr = filter (not.isFollowableRep) reps + + ptrs_szw = sum (map untaggedSizeW reps_ptr) + ptrs_code | null reps_ptr = nilOL + | otherwise = unitOL (UNPACK ptrs_szw) + + do_nptrs off_h off_s [] = nilOL + do_nptrs off_h off_s (npr:nprs) + = case npr of + IntRep -> approved ; FloatRep -> approved + DoubleRep -> approved ; AddrRep -> approved + _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) + where + approved = UPK_TAG usizeW off_h off_s `consOL` theRest + theRest = do_nptrs (off_h + usizeW) (off_s + tsizeW) nprs + usizeW = untaggedSizeW npr + tsizeW = taggedSizeW npr + -- Push an atom onto the stack, returning suitable code & number of -- stack words used. Pushes it either tagged or untagged, since @@ -699,6 +704,9 @@ pushAtom False d p (AnnLit lit) pushAtom tagged d p (AnnApp f (_, AnnType _)) = pushAtom tagged d p (snd f) +pushAtom tagged d p (AnnNote note e) + = pushAtom tagged d p (snd e) + pushAtom tagged d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) @@ -1088,12 +1096,10 @@ mkBits findLabel st proto_insns ret_itbl_addr = case pk of PtrRep -> stg_ctoi_ret_R1_info IntRep -> stg_ctoi_ret_R1_info + CharRep -> stg_ctoi_ret_R1_info FloatRep -> stg_ctoi_ret_F1_info DoubleRep -> stg_ctoi_ret_D1_info _ -> pprPanic "mkBits.ctoi_itbl" (ppr pk) - where -- TEMP HACK - stg_ctoi_ret_F1_info = nullAddr - stg_ctoi_ret_D1_info = nullAddr itoc_itbl st pk = addr st ret_itbl_addr @@ -1104,8 +1110,8 @@ mkBits findLabel st proto_insns DoubleRep -> stg_gc_d1_info foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr ---foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr ---foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr +foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr +foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 499998d..e699088 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.24 2000/12/18 12:43:04 sewardj Exp $ +-- $Id: InteractiveUI.hs,v 1.25 2001/01/10 17:19:01 sewardj Exp $ -- -- GHC Interactive User Interface -- @@ -162,7 +162,9 @@ runCommand c = doCommand c doCommand (':' : command) = specialCommand command -doCommand expr = timeIt (evalExpr expr) >> return False +doCommand expr = do timeIt (evalExpr expr + >> evalExpr "Prelude.putStr \"\n\"") + return False evalExpr expr = do st <- getGHCiState diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index daf5bb5..83009b9 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.9 $ - * $Date: 2001/01/09 17:36:21 $ + * $Revision: 1.10 $ + * $Date: 2001/01/10 17:21:18 $ * ---------------------------------------------------------------------------*/ #ifdef GHCI @@ -129,6 +129,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) /* Start of the bytecode interpreter */ /* ---------------------------------------------------- */ { + int do_print_stack = 1; register int bciPtr = 1; /* instruction pointer */ register StgBCO* bco = (StgBCO*)obj; register UShort* instrs = (UShort*)(&bco->instrs->payload[0]); @@ -146,9 +147,12 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) ASSERT(bciPtr <= instrs[0]); IF_DEBUG(evaluator, + //if (do_print_stack) { //fprintf(stderr, "\n-- BEGIN stack\n"); //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); //fprintf(stderr, "-- END stack\n\n"); + //} + do_print_stack = 1; fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr); disInstr(bco,bciPtr); if (0) { int i; @@ -189,6 +193,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) ASSERT((W_*)iSp+o1 < (W_*)iSu); StackWord(-1) = StackWord(o1); iSp--; + do_print_stack = 0; goto nextInsn; } case bci_PUSH_LL: { @@ -224,13 +229,13 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) goto nextInsn; } case bci_PUSH_UBX: { + int i; int o_lits = BCO_NEXT; int n_words = BCO_NEXT; - for (; n_words > 0; n_words--) { - iSp --; - StackWord(0) = BCO_LIT(o_lits); - o_lits++; - } + iSp -= n_words; + for (i = 0; i < n_words; i++) + StackWord(i) = BCO_LIT(o_lits+i); + do_print_stack = 0; goto nextInsn; } case bci_PUSH_TAG: { @@ -331,17 +336,50 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) bciPtr = failto; goto nextInsn; } + case bci_TESTLT_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)); + if (stackInt >= (I_)BCO_LIT(discr)) + 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; } + case bci_TESTLT_D: { + /* The top thing on the stack should be a tagged double. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + ASSERT(sizeofW(StgDouble) == StackWord(0)); + stackDbl = PK_DBL( & StackWord(1) ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl >= discrDbl) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_D: { + /* The top thing on the stack should be a tagged double. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + ASSERT(sizeofW(StgDouble) == StackWord(0)); + stackDbl = PK_DBL( & StackWord(1) ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl != discrDbl) + bciPtr = failto; + goto nextInsn; + } /* Control-flow ish things */ case bci_ENTER: { @@ -355,8 +393,8 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) 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 */) { + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info) { /* Returning to interpreted code. Interpret the BCO immediately underneath the itbl. */ StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1); @@ -379,11 +417,8 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) barf("interpretBCO: hit a CASEFAIL"); /* As yet unimplemented */ - case bci_TESTLT_I: case bci_TESTLT_F: case bci_TESTEQ_F: - case bci_TESTLT_D: - case bci_TESTEQ_D: /* Errors */ default: diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index 2c0651e..7bfc7c6 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Linker.c,v 1.6 2000/12/15 17:29:35 simonmar Exp $ + * $Id: Linker.c,v 1.7 2001/01/10 17:21:18 sewardj Exp $ * * (c) The GHC Team, 2000 * @@ -133,6 +133,7 @@ static int ocResolve_PEi386 ( ObjectCode* oc ); SymX(stg_IND_STATIC_info) \ SymX(stg_EMPTY_MVAR_info) \ SymX(stg_MUT_ARR_PTRS_FROZEN_info) \ + SymX(stg_WEAK_info) \ SymX(stg_CHARLIKE_closure) \ SymX(stg_INTLIKE_closure) \ SymX(stg_CAF_UNENTERED_entry) \ diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c index ed47cfb..309edb1 100644 --- a/ghc/rts/Printer.c +++ b/ghc/rts/Printer.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Printer.c,v 1.31 2001/01/05 15:24:28 sewardj Exp $ + * $Id: Printer.c,v 1.32 2001/01/10 17:21:18 sewardj Exp $ * * (c) The GHC Team, 1994-2000. * @@ -388,7 +388,6 @@ StgPtr printStackObj( StgPtr sp ) if (c == (StgClosure*)&stg_ctoi_ret_R1_info) { fprintf(stderr, "\t\t\tstg_ctoi_ret_R1_info\n" ); } else -#if 0 if (c == (StgClosure*)&stg_ctoi_ret_F1_info) { fprintf(stderr, "\t\t\tstg_ctoi_ret_F1_info\n" ); } else @@ -396,7 +395,6 @@ StgPtr printStackObj( StgPtr sp ) fprintf(stderr, "\t\t\tstg_ctoi_ret_D1_info\n" ); } else #endif -#endif if (get_itbl(c)->type == BCO) { fprintf(stderr, "\t\t\t"); fprintf(stderr, "BCO(...)\n"); diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index e78f633..51b57c3 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.hc,v 1.56 2000/12/15 10:37:51 sewardj Exp $ + * $Id: StgMiscClosures.hc,v 1.57 2001/01/10 17:21:18 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -136,9 +136,59 @@ STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_7_entry); 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 ... */ -/* TODO */ +#define STG_CtoI_RET_F1_Template(label) \ + IFN_(label) \ + { \ + StgPtr bco; \ + FB_ \ + bco = ((StgPtr*)Sp)[1]; \ + Sp -= sizeofW(StgFloat); \ + ASSIGN_FLT((W_*)Sp, F1); \ + Sp -= 1; \ + ((StgPtr*)Sp)[0] = bco; \ + JMP_(stg_yield_to_interpreter); \ + FE_ \ + } + +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_0_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_1_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_2_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_3_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_4_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_5_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_6_entry); +STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_7_entry); + +VEC_POLY_INFO_TABLE(stg_ctoi_ret_F1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_); + + /* When the returned value is in D1 ... */ -/* TODO */ +#define STG_CtoI_RET_D1_Template(label) \ + IFN_(label) \ + { \ + StgPtr bco; \ + FB_ \ + bco = ((StgPtr*)Sp)[1]; \ + Sp -= sizeofW(StgDouble); \ + ASSIGN_DBL((W_*)Sp, D1); \ + Sp -= 1; \ + ((StgPtr*)Sp)[0] = bco; \ + JMP_(stg_yield_to_interpreter); \ + FE_ \ + } + +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_0_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_1_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_2_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_3_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_4_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_5_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_6_entry); +STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_7_entry); + +VEC_POLY_INFO_TABLE(stg_ctoi_ret_D1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_); /* The other way round: when the interpreter returns a value to -- 1.7.10.4