[project @ 2001-01-09 17:36:21 by sewardj]

Various bug fixes for the interpreter/byte-code-gen combination.

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index a5b10ca..af4e1b9 100644 (file)
--- 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 f993fee..daf5bb5 100644 (file)
--- 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 4ba2731..612874b 100644 (file)
--- 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; }