From b9ad54f9b2bb99d2d3d62c61e2da71e076938f18 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 27 Apr 1999 10:07:25 +0000 Subject: [PATCH] [project @ 1999-04-27 10:06:47 by sewardj] Changes to improve runtime performance of STG Hugs. -- Reorganisation of the evaluator (Evaluator.c). -- Changes to code emission (Assembler.c) to support peephole opts -- An experimental simplifier (optimise.c). -- Many supporting bug fixes and minor changes. -- Experimental implementation of integer for standalone hugs (sainteger.c). --- ghc/includes/Assembler.h | 26 +- ghc/includes/options.h | 74 +- ghc/interpreter/Makefile | 34 +- ghc/interpreter/backend.h | 98 +- ghc/interpreter/codegen.c | 89 +- ghc/interpreter/command.h | 8 +- ghc/interpreter/compiler.c | 107 +- ghc/interpreter/connect.h | 78 +- ghc/interpreter/derive.c | 208 +- ghc/interpreter/free.c | 20 +- ghc/interpreter/hugs.c | 137 +- ghc/interpreter/input.c | 101 +- ghc/interpreter/lib/Array.hs | 2 +- ghc/interpreter/lib/IO.hs | 255 +++ ghc/interpreter/lib/Prelude.hs | 195 +- ghc/interpreter/lib/System.hs | 48 + ghc/interpreter/lift.c | 56 +- ghc/interpreter/link.c | 636 +++--- ghc/interpreter/link.h | 34 - ghc/interpreter/machdep.c | 29 +- ghc/interpreter/nHandle.c | 40 +- ghc/interpreter/optimise.c | 2515 +++++++++++++++++++-- ghc/interpreter/output.c | 16 +- ghc/interpreter/parser.y | 8 +- ghc/interpreter/preds.c | 7 +- ghc/interpreter/runallnofib | 119 + ghc/interpreter/runnofib | 51 + ghc/interpreter/sainteger.c | 968 ++++++++ ghc/interpreter/sainteger.h | 47 + ghc/interpreter/scc.c | 16 +- ghc/interpreter/static.c | 292 +-- ghc/interpreter/stg.c | 255 ++- ghc/interpreter/stgSubst.c | 71 +- ghc/interpreter/storage.c | 563 +---- ghc/interpreter/storage.h | 112 +- ghc/interpreter/subst.c | 23 +- ghc/interpreter/translate.c | 81 +- ghc/interpreter/type.c | 73 +- ghc/lib/hugs/Prelude.hs | 195 +- ghc/rts/Assembler.c | 662 ++---- ghc/rts/Bytecodes.h | 281 +-- ghc/rts/Disassembler.c | 53 +- ghc/rts/Evaluator.c | 4751 ++++++++++++++++++++++------------------ ghc/rts/QueueTemplate.h | 124 +- 44 files changed, 8116 insertions(+), 5442 deletions(-) create mode 100644 ghc/interpreter/lib/IO.hs create mode 100644 ghc/interpreter/lib/System.hs create mode 100644 ghc/interpreter/runallnofib create mode 100644 ghc/interpreter/runnofib create mode 100644 ghc/interpreter/sainteger.c create mode 100644 ghc/interpreter/sainteger.h diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index 1d50fac..913ec9e 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Assembler.h,v 1.5 1999/03/01 14:47:09 sewardj Exp $ + * $Id: Assembler.h,v 1.6 1999/04/27 10:07:22 sewardj Exp $ * * (c) The GHC Team 1994-1998. * @@ -84,18 +84,9 @@ typedef enum { /* The following can be passed to C */ CHAR_REP = 'C', INT_REP = 'I', -#ifdef PROVIDE_INT64 - INT64_REP = 'z', -#endif -#ifdef PROVIDE_INTEGER INTEGER_REP = 'Z', -#endif -#ifdef PROVIDE_WORD WORD_REP = 'W', -#endif -#ifdef PROVIDE_ADDR ADDR_REP = 'A', -#endif FLOAT_REP = 'F', DOUBLE_REP = 'D', #ifdef PROVIDE_STABLE @@ -107,10 +98,8 @@ typedef enum { #ifdef PROVIDE_WEAK WEAK_REP = 'w', /* Weak a */ #endif -#ifdef PROVIDE_ARRAY BARR_REP = 'x', /* PrimByteArray a */ MUTBARR_REP = 'm', /* PrimMutableByteArray s a */ -#endif /* The following can't be passed to C */ PTR_REP = 'P', @@ -121,11 +110,9 @@ typedef enum { IO_REP = 'i', /* IO a */ HANDLER_REP = 'H', /* Exception -> IO a */ ERROR_REP = 'E', /* Exception */ -#ifdef PROVIDE_ARRAY ARR_REP = 'X', /* PrimArray a */ REF_REP = 'R', /* Ref s a */ MUTARR_REP = 'M', /* PrimMutableArray s a */ -#endif #ifdef PROVIDE_CONCURRENT THREADID_REP = 'T', /* ThreadId */ MVAR_REP = 'r', /* MVar a */ @@ -164,6 +151,8 @@ extern int asmObjectHasClosure( AsmObject obj ); extern AsmClosure asmClosureOfObject ( AsmObject obj ); extern void asmMarkObject ( AsmObject obj ); +extern int asmRepSizeW ( AsmRep rep ); + /* -------------------------------------------------------------------------- * Generating instruction streams * ------------------------------------------------------------------------*/ @@ -194,21 +183,12 @@ extern void asmReturnUnboxed ( AsmBCO bco, AsmRep rep ); /* push unboxed Ints, Floats, etc */ extern void asmConstInt ( AsmBCO bco, AsmInt x ); -#ifdef PROVIDE_ADDR extern void asmConstAddr ( AsmBCO bco, AsmAddr x ); -#endif -#ifdef PROVIDE_WORD extern void asmConstWord ( AsmBCO bco, AsmWord x ); -#endif extern void asmConstChar ( AsmBCO bco, AsmChar x ); extern void asmConstFloat ( AsmBCO bco, AsmFloat x ); extern void asmConstDouble ( AsmBCO bco, AsmDouble x ); -#ifdef PROVIDE_INT64 -extern void asmConstInt64 ( AsmBCO bco, AsmInt64 x ); -#endif -#ifdef PROVIDE_INTEGER extern void asmConstInteger ( AsmBCO bco, AsmString x ); -#endif /* Which monad (if any) does the primop live in? */ typedef enum { diff --git a/ghc/includes/options.h b/ghc/includes/options.h index e640dec..4033d0d 100644 --- a/ghc/includes/options.h +++ b/ghc/includes/options.h @@ -13,8 +13,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: options.h,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:47:09 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:07:22 $ * ------------------------------------------------------------------------*/ @@ -34,7 +34,7 @@ * for HUGSFLAGS in the registry (Win32 only). In all cases, use a * string of the form -P"...". */ -#define HUGSPATH "" +#define HUGSPATH "." /* The directory name which is substituted for the string "{Hugs}" * in a path variable. This normally points to where the Hugs libraries @@ -104,7 +104,7 @@ #define LARGE_HUGS 1 #define NUM_SYNTAX 100 -#define NUM_TUPLES /*100*/ 10 +#define NUM_TUPLES /*100*/ 20 #define NUM_OFFSETS 1024 #define NUM_CHARS 256 #if TREX @@ -124,7 +124,7 @@ #define MINIMUMHEAP Pick(7500, 19000, 19000) #define MAXIMUMHEAP Pick(32765, 0, 0) -#define DEFAULTHEAP Pick(28000, 50000, 1500000 /*300000*/ ) +#define DEFAULTHEAP Pick(28000, 50000, 650000) #define NUM_SCRIPTS Pick(64, 100, 100) #define NUM_MODULE NUM_SCRIPTS @@ -173,58 +173,40 @@ /* Should quantifiers be displayed in error messages. * Warning: not consistently used. */ -#define DISPLAY_QUANTIFIERS 1 +#define DISPLAY_QUANTIFIERS 0 /* Flags to determine which raw representations and operations are available * Notes: - * o the INTEGER implementation is quite different from GHC's - * implementation so you usually don't PROVIDE_INTEGER if - * using GHC compiled code. * o if you turn everything on, you might end up with more then 256 * bytecodes: check the value of i_ccall (the lst bytecode) to check - * o Addrs are used to represent literal Strings in Hugs - so you can't - * really turn them off. - * o Either Int64 or Integer has to be provided so that we can - * define BIGNUMTYPE (below) + * (JRS), 22apr99: I don't think any of the #undef'd ones will work + * without attention. However, standard Haskell 98 is supported + * is supported without needing them. */ - -#define PROVIDE_INTEGER -#undef PROVIDE_INT64 -#undef PROVIDE_WORD -#define PROVIDE_ADDR #undef PROVIDE_STABLE -#define PROVIDE_FOREIGN +#undef PROVIDE_FOREIGN #undef PROVIDE_WEAK -#define PROVIDE_ARRAY #undef PROVIDE_CONCURRENT #undef PROVIDE_PTREQUALITY #undef PROVIDE_COERCE -/* The following aren't options at the moment - but could be - * #define PROVIDE_FLOAT - * #define PROVIDE_DOUBLE - */ -/* Flags to determine how Haskell types are mapped onto internal types. - * Note that this has to be an injection: you can't have two names - * for the same internal type. - * Also, the settings have to be consistent with GHC if GHC is being used. - */ +/* Set to 1 to use a non-GMP implementation of integer, in the + standalone Hugs. Set to 0 in the combined GHC-Hugs system, + in which case GNU MP will be used. +*/ +#define STANDALONE_INTEGER 1 -#define BIGNUM_IS_INTEGER 1 -#define BIGNUM_IS_INT64 0 +/* Enable a crude profiler which counts BCO entries, bytes allocated + and bytecode insns executed on a per-fn basis. Used for assessing + the effect of the simplifier/optimiser. +*/ +#undef CRUDE_PROFILING -#if BIGNUM_IS_INT64 -#define BIGNUMTYPE Int64 -#elif BIGNUM_IS_INTEGER -#define BIGNUMTYPE Integer -#else -#warning BIGNUMTYPE undefined -#endif /* Is the default default (Int,Double) or (Integer,Double)? */ -#define DEFAULT_BIGNUM 0 +#define DEFAULT_BIGNUM 1 /* Should lambda lifter lift constant expressions out to top level? * Experimental optimisation. @@ -234,7 +216,7 @@ /* Should we run optimizer on Hugs code? * Experimental optimisation. */ -#define USE_HUGS_OPTIMIZER 0 +#define USE_HUGS_OPTIMIZER 1 /* Are things being used in an interactive setting or a batch setting? * In an interactive setting, System.exitWith should not call _exit @@ -324,15 +306,6 @@ * these flags. * ------------------------------------------------------------------------*/ -/* Define if you want to be able to derive instances of each class. */ -#define DERIVE_EQ 1 -#define DERIVE_ORD 1 -#define DERIVE_ENUM 1 -#define DERIVE_IX 1 -#define DERIVE_SHOW 1 -#define DERIVE_READ 1 -#define DERIVE_BOUNDED 1 - /* Define if single-element dictionaries are implemented by newtype. * Should be turned on. Mostly used to make it easier to find which * bits of code implement this optimisation and as a way of documenting @@ -351,9 +324,6 @@ * or "fromFloat" */ #define OVERLOADED_CONSTANTS 1 -/* turn this off to remove the ultramagical treatment of the Eval class */ -#define EVAL_INSTANCES 0 - /* Define to include support for (n+k) patterns. * Warning: many people in the Haskell committee want to remove n+k patterns. */ diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile index c7d5d20..b6452f2 100644 --- a/ghc/interpreter/Makefile +++ b/ghc/interpreter/Makefile @@ -1,6 +1,6 @@ # ----------------------------------------------------------------------------- # -# $Id: Makefile,v 1.6 1999/03/09 14:51:03 sewardj Exp $ # +# $Id: Makefile,v 1.7 1999/04/27 10:06:47 sewardj Exp $ # # ----------------------------------------------------------------------------- # TOP = ../.. @@ -24,30 +24,25 @@ HS_SRCS = Y_SRCS = parser.y C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \ translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \ - hugs.c dynamic.c stg.c + hugs.c dynamic.c stg.c sainteger.c -SRC_CC_OPTS = -O2 -Winline -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wstrict-prototypes +SRC_CC_OPTS = -O2 -g -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/gmp/libgmp.a -GHC_DYN_CBITS_DIR = $(TOP)/ghc/lib/std/cbits -GHC_DYN_CBITS = $(GHC_DYN_CBITS_DIR)/libHS_cbits.so +GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a -all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs +all :: parser.c $(GHC_LIBS_NEEDED) nHandle.so hugs ### EXTREMELY hacky -hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o ../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o \ - ../rts/Printer.o - $(CC) -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm +hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o \ + ../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o ../rts/Printer.o \ + nHandle.so + $(CC) -o $@ -rdynamic $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm -$(GHC_DYN_CBITS): -### (cd $(GHC_DYN_CBITS_DIR); make EXTRA_CC_OPTS="-fpic -optc-g" ; gcc -shared -o libHS_cbits.so *.o) - (cd $(GHC_DYN_CBITS_DIR); rm -f *.o ; gcc -I../../../includes -fPIC -g -Wall -c *.c ; gcc -shared -o libHS_cbits.so *.o) - cp -f $(GHC_DYN_CBITS) . +nHandle.so: + gcc -O -fPIC -shared -o nHandle.so nHandle.c $(TOP)/ghc/rts/libHSrts.a: (cd $(TOP)/ghc/rts ; make clean ; make) -$(TOP)/ghc/rts/gmp/libgmp.a: - (cd $(TOP)/ghc/rts/gmp ; make clean ; make) cleanish: /bin/rm *.o @@ -56,10 +51,10 @@ snapshot: /bin/rm -f snapshot.tar tar cvf snapshot.tar Makefile *.[chy] *-ORIG-* \ ../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \ - ../rts/ForeignCall.c ../rts/Printer.c \ + ../rts/ForeignCall.c ../rts/Printer.c ../rts/QueueTemplate.h \ ../includes/options.h ../includes/Assembler.h nHandle.c \ ../includes/Assembler.h ../rts/Bytecodes.h \ - lib/*.hs + lib/*.hs runnofib runallnofib # --------------------------------------------------------------------- # @@ -82,9 +77,8 @@ checkrun: all # Cleanery & misc # # --------------------------------------------------------------------- # -CLEAN_FILES += hugs libHS_cbits.so $(GHC_DYN_CBITS) $(GHC_DYN_CBITS_DIR)/*.o +CLEAN_FILES += hugs nHandle.so CLEAN_FILES += $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/*.o -CLEAN_FILES += $(TOP)/ghc/rts/gmp/libgmp.a $(TOP)/ghc/rts/gmp/*.o $(TOP)/ghc/rts/gmp/*/*.o CLEAN_FILES += parser.c INSTALL_LIBEXECS = hugs diff --git a/ghc/interpreter/backend.h b/ghc/interpreter/backend.h index 5334454..36e132c 100644 --- a/ghc/interpreter/backend.h +++ b/ghc/interpreter/backend.h @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: backend.h,v $ - * $Revision: 1.3 $ - * $Date: 1999/03/09 14:51:04 $ + * $Revision: 1.4 $ + * $Date: 1999/04/27 10:06:47 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -38,10 +38,10 @@ * | Name -- let-bound (effectively) * -- always unboxed (PTR_REP) * - * Alt -> (Pat,Expr) - * Pat -> Var -- bound to a constructor, a tuple or unbound - * PrimAlt -> ([PrimPat],Expr) - * PrimPat -> Var -- bound to int or unbound + * Alt -> DEEFALT (Var,Expr) -- var bound to NIL + * | CASEALT (Con,[Var],Expr) -- vars bound to NIL; + * -- Con is Name or TUPLE + * PrimAlt -> PRIMALT ([Var],Expr) -- vars bound to NIL or int * * We use pointer equality to distinguish variables. * The info field of a Var is used as follows in various phases: @@ -50,66 +50,64 @@ * Freevar analysis: list of free vars after * Lambda lifting: freevar list or UNIT on input, discarded after * Code generation: unused + * Optimisation: number of uses (sort-of) of let-bound variable * ------------------------------------------------------------------------*/ typedef Cell StgRhs; typedef Cell StgExpr; typedef Cell StgAtom; typedef Cell StgVar; /* Could be a Name or an STGVAR */ -typedef Pair StgCaseAlt; -typedef StgVar StgPat; +typedef Cell StgCaseAlt; +typedef Cell StgPrimAlt; typedef Cell StgDiscr; -typedef Pair StgPrimAlt; -typedef StgVar StgPrimPat; typedef Cell StgRep; /* PTR_REP | .. DOUBLE_REP */ -#define mkStgLet(binds,body) ap(LETREC,pair(binds,body)) -#define stgLetBinds(e) fst(snd(e)) -#define stgLetBody(e) snd(snd(e)) +#define mkStgLet(binds,body) ap(LETREC,pair(binds,body)) +#define stgLetBinds(e) fst(snd(e)) +#define stgLetBody(e) snd(snd(e)) #define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info)) #define stgVarBody(e) fst3(snd(e)) #define stgVarRep(e) snd3(snd(e)) #define stgVarInfo(e) thd3(snd(e)) -#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts)) -#define stgCaseScrut(e) fst(snd(e)) -#define stgCaseAlts(e) snd(snd(e)) +#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts)) +#define stgCaseScrut(e) fst(snd(e)) +#define stgCaseAlts(e) snd(snd(e)) -#define mkStgCaseAlt(discr,vs,e) pair(mkStgVar(mkStgCon(discr,vs),NIL),e) -#define stgCaseAltPat(alt) fst(alt) -#define stgCaseAltBody(alt) snd(alt) +#define mkStgCaseAlt(con,vs,e) ap(CASEALT,triple(con,vs,e)) +#define stgCaseAltCon(alt) fst3(snd(alt)) +#define stgCaseAltVars(alt) snd3(snd(alt)) +#define stgCaseAltBody(alt) thd3(snd(alt)) -#define stgPatDiscr(pat) stgConCon(stgVarBody(pat)) -#define stgPatVars(pat) stgConArgs(stgVarBody(pat)) +#define mkStgDefault(v,e) ap(DEEFALT,pair(v,e)) +#define stgDefaultVar(alt) fst(snd(alt)) +#define stgDefaultBody(alt) snd(snd(alt)) +#define isDefaultAlt(alt) (fst(alt)==DEEFALT) -#define isDefaultPat(pat) (isNull(stgVarBody(pat))) -#define isStgDefault(alt) (isDefaultPat(stgCaseAltPat(alt))) -#define mkStgDefault(v,e) pair(v,e) +#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts)) +#define stgPrimCaseScrut(e) fst(snd(e)) +#define stgPrimCaseAlts(e) snd(snd(e)) -#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts)) -#define stgPrimCaseScrut(e) fst(snd(e)) -#define stgPrimCaseAlts(e) snd(snd(e)) +#define mkStgPrimAlt(vs,body) ap(PRIMALT,pair(vs,body)) +#define stgPrimAltVars(alt) fst(snd(alt)) +#define stgPrimAltBody(alt) snd(snd(alt)) -#define mkStgPrimAlt(vs,body) pair(vs,body) -#define stgPrimAltPats(alt) fst(alt) -#define stgPrimAltBody(alt) snd(alt) +#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args)) +#define stgAppFun(e) fst(snd(e)) +#define stgAppArgs(e) snd(snd(e)) -#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args)) -#define stgAppFun(e) fst(snd(e)) -#define stgAppArgs(e) snd(snd(e)) +#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args)) +#define stgPrimOp(e) fst(snd(e)) +#define stgPrimArgs(e) snd(snd(e)) -#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args)) -#define stgPrimOp(e) fst(snd(e)) -#define stgPrimArgs(e) snd(snd(e)) +#define mkStgCon(con,args) ap(STGCON,pair(con,args)) +#define stgConCon(e) fst(snd(e)) +#define stgConArgs(e) snd(snd(e)) -#define mkStgCon(con,args) ap(STGCON,pair(con,args)) -#define stgConCon(e) fst(snd(e)) -#define stgConArgs(e) snd(snd(e)) - -#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body)) -#define stgLambdaArgs(e) fst(snd(e)) -#define stgLambdaBody(e) snd(snd(e)) +#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body)) +#define stgLambdaArgs(e) fst(snd(e)) +#define stgLambdaBody(e) snd(snd(e)) extern int stgConTag ( StgDiscr d ); extern void* stgConInfo ( StgDiscr d ); @@ -126,9 +124,10 @@ extern StgExpr makeStgLet ( List binds, StgExpr body ); extern StgExpr makeStgIf ( StgExpr cond, StgExpr e1, StgExpr e2 ); extern Bool isStgVar ( StgRhs rhs ); extern Bool isAtomic ( StgRhs rhs ); - extern StgVar mkStgVar ( StgRhs rhs, Cell info ); +extern Int stgSize ( StgExpr e ); + #define mkStgRep(c) mkChar(c) /*-------------------------------------------------------------------------*/ @@ -179,7 +178,16 @@ extern Void ppStgVars ( List vs ); extern List liftBinds( List binds ); extern Void liftControl ( Int what ); -extern StgExpr substExpr ( List sub, StgExpr e ); +extern StgExpr substExpr ( List sub, StgExpr e ); +extern StgExpr zubstExpr ( List sub, StgExpr e ); + extern List freeVarsBind Args((List, StgVar)); extern Void optimiseBind Args((StgVar)); +#ifdef CRUDE_PROFILING +extern void cp_init ( void ); +extern void cp_enter ( Cell /*StgVar*/ ); +extern void cp_bill_words ( int ); +extern void cp_bill_insns ( int ); +extern void cp_show ( void ); +#endif diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index 4205951..ca9b482 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: codegen.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:04 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:06:48 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -48,6 +48,8 @@ static AsmBCO cgRhs ( StgRhs rhs ); static void beginTop ( StgVar v ); static void endTop ( StgVar v ); +static StgVar currentTop; + /* -------------------------------------------------------------------------- * * ------------------------------------------------------------------------*/ @@ -105,11 +107,7 @@ static void cgBind( AsmBCO bco, StgVar v ) static Void pushVar( AsmBCO bco, StgVar v ) { Cell info = stgVarInfo(v); - // if (!isStgVar(v)) { - //printf("\n\nprefail\n"); - //print(v,1000); - assert(isStgVar(v)); - //} + assert(isStgVar(v)); if (isPtr(info)) { asmClosure(bco,ptrOf(info)); } else if (isInt(info)) { @@ -134,17 +132,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) case INTCELL: asmConstInt(bco,intOf(e)); break; -#if BIGNUM_IS_INTEGER case BIGCELL: asmConstInteger(bco,bignumToString(e)); break; -#elif BIGNUM_IS_INT64 - case BIGCELL: - asmConstInt64(bco,bignumOf(e)); - break; -#else -#warning What is BIGNUM? -#endif case FLOATCELL: #if 0 asmConstFloat(bco,e); /* ToDo: support both float and double! */ @@ -175,24 +165,26 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts ) { - AsmBCO bco = asmBeginContinuation(sp,alts); +#ifdef CRUDE_PROFILING + AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000); +#else + AsmBCO bco = asmBeginContinuation(sp, alts); +#endif /* ppStgAlts(alts); */ for(; nonNull(alts); alts=tl(alts)) { StgCaseAlt alt = hd(alts); - StgPat pat = stgCaseAltPat(alt); - StgExpr body = stgCaseAltBody(alt); - if (isDefaultPat(pat)) { - //AsmSp begin = asmBeginAlt(bco); - cgBind(bco,pat); - cgExpr(bco,root,body); + if (isDefaultAlt(alt)) { + cgBind(bco,stgDefaultVar(alt)); + cgExpr(bco,root,stgDefaultBody(alt)); asmEndContinuation(bco); return bco; /* ignore any further alternatives */ } else { - StgDiscr con = stgPatDiscr(pat); - List vs = stgPatVars(pat); + StgDiscr con = stgCaseAltCon(alt); + List vs = stgCaseAltVars(alt); AsmSp begin = asmBeginAlt(bco); - AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */ - cgBind(bco,pat); + AsmPc fix = asmTest(bco,stgDiscrTag(con)); + /* ToDo: omit in single constructor types! */ + asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */ if (isBoxingCon(con)) { setPos(hd(vs),asmUnbox(bco,boxingConRep(con))); } else { @@ -200,7 +192,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts ) map1Proc(cgBind,bco,reverse(vs)); asmEndUnpack(bco); } - cgExpr(bco,root,body); + cgExpr(bco,root,stgCaseAltBody(alt)); asmEndAlt(bco,begin); asmFixBranch(bco,fix); } @@ -216,7 +208,7 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e ) if (isNull(pats)) { cgExpr(bco,root,e); } else { - StgPrimPat pat = hd(pats); + StgVar pat = hd(pats); if (isInt(stgVarBody(pat))) { /* asmTestInt leaves stack unchanged - so no need to adjust it */ AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat))); @@ -310,7 +302,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) for(; nonNull(alts); alts=tl(alts)) { StgPrimAlt alt = hd(alts); - List pats = stgPrimAltPats(alt); + List pats = stgPrimAltVars(alt); StgExpr body = stgPrimAltBody(alt); AsmSp altBegin = asmBeginAlt(bco); map1Proc(cgBind,bco,reverse(pats)); @@ -331,7 +323,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) for(; nonNull(alts); alts=tl(alts)) { StgPrimAlt alt = hd(alts); - List pats = stgPrimAltPats(alt); + List pats = stgPrimAltVars(alt); StgExpr body = stgPrimAltBody(alt); AsmSp altBegin = asmBeginAlt(bco); map1Proc(cgBind,bco,pats); @@ -399,7 +391,9 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) } } -void* itblNames[1000]; +#define M_ITBLNAMES 35000 + +void* itblNames[M_ITBLNAMES]; int nItblNames = 0; /* allocate space for top level variable @@ -420,7 +414,8 @@ static Void alloc( AsmBCO bco, StgVar v ) } else { void* vv = stgConInfo(con); - assert (nItblNames < (1000-2)); + if (!(nItblNames < (M_ITBLNAMES-2))) + internal("alloc -- M_ITBLNAMES too small"); if (isName(con)) { itblNames[nItblNames++] = vv; itblNames[nItblNames++] = textToStr(name(con).text); @@ -438,9 +433,21 @@ static Void alloc( AsmBCO bco, StgVar v ) } break; } - case STGAPP: - setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs)))); + case STGAPP: { + Int totSizeW = 0; + List bs = stgAppArgs(rhs); + for (; nonNull(bs); bs=tl(bs)) { + if (isName(hd(bs))) { + totSizeW += 1; + } else { + ASSERT(whatIs(hd(bs))==STGVAR); + totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) ); + } + } + setPos(v,asmAllocAP(bco,totSizeW)); + //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs)))); break; + } case LAMBDA: /* optimisation */ setObj(v,cgLambda(rhs)); break; @@ -548,6 +555,7 @@ static void beginTop( StgVar v ) { StgRhs rhs; assert(isStgVar(v)); + currentTop = v; rhs = stgVarBody(v); switch (whatIs(rhs)) { case STGCON: @@ -557,7 +565,11 @@ static void beginTop( StgVar v ) break; } case LAMBDA: +#ifdef CRUDE_PROFILING + setObj(v,asmBeginBCO(currentTop)); +#else setObj(v,asmBeginBCO(rhs)); +#endif break; default: setObj(v,asmBeginCAF()); @@ -568,7 +580,7 @@ static void beginTop( StgVar v ) static void endTop( StgVar v ) { StgRhs rhs = stgVarBody(v); - //ppStgRhs(rhs); + currentTop = v; switch (whatIs(rhs)) { case STGCON: { @@ -656,18 +668,13 @@ Void cgBinds( List binds ) } #endif - //mapProc(beginTop,binds); for (b=binds,i=0; nonNull(b); b=tl(b),i++) { - //printf("beginTop %d\n", i); beginTop(hd(b)); } - //mapProc(endTop,binds); for (b=binds,i=0; nonNull(b); b=tl(b),i++) { + //printf("endTop %s\n", maybeName(hd(b))); endTop(hd(b)); - //if (lastModule() != modulePrelude) { - // printStg ( stdout, hd(b) ); printf("\n\n"); - //} } //mapProc(zap,binds); diff --git a/ghc/interpreter/command.h b/ghc/interpreter/command.h index d709554..b6a1018 100644 --- a/ghc/interpreter/command.h +++ b/ghc/interpreter/command.h @@ -7,8 +7,8 @@ * in the distribution for details. * * $RCSfile: command.h,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:26 $ + * $Revision: 1.4 $ + * $Date: 1999/04/27 10:06:48 $ * ------------------------------------------------------------------------*/ typedef Int Command; @@ -38,6 +38,8 @@ extern Command readCommand Args((struct cmd *, Char, Char)); #define INFO 15 #define COLLECT 16 #define SETMODULE 17 -#define NOCMD 18 +#define DUMP 18 +#define STATS 19 +#define NOCMD 20 /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 7591e78..112ae6d 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -10,8 +10,8 @@ * in the distribution for details. * * $RCSfile: compiler.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:05 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:06:48 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -81,6 +81,8 @@ static Bool local eqExtDiscr Args((Cell,Cell)); static Void local compileGlobalFunction Args((Pair)); static Void local compileGenFunction Args((Name)); static Name local compileSelFunction Args((Pair)); +static List local addStgVar Args((List,Pair)); + /* -------------------------------------------------------------------------- * Translation: Convert input expressions into a less complex language @@ -101,12 +103,6 @@ Cell e; { if (fst(e)==nameId || fst(e)==nameInd) return translate(snd(e)); -#if EVAL_INSTANCES - if (fst(e)==nameStrict) - return nameIStrict; - if (fst(e)==nameSeq) - return nameISeq; -#endif if (isName(fst(e)) && isMfun(fst(e)) && mfunOf(fst(e))==0) @@ -115,11 +111,6 @@ Cell e; { snd(e) = translate(snd(e)); return e; -#if BIGNUMS - case POSNUM : - case ZERONUM : - case NEGNUM : return e; -#endif case NAME : if (e==nameOtherwise) return nameTrue; if (isCfun(e)) { @@ -142,6 +133,7 @@ Cell e; { case INTCELL : case FLOATCELL : case STRCELL : + case BIGCELL : case CHARCELL : return e; case FINLIST : mapOver(translate,snd(e)); @@ -927,11 +919,6 @@ Cell e; { /* e = expr to transform */ case AP : return pmcPair(co,sc,e); -#if BIGNUMS - case POSNUM : - case ZERONUM : - case NEGNUM : -#endif #if NPLUSK case ADDPAT : #endif @@ -942,6 +929,7 @@ Cell e; { /* e = expr to transform */ case NAME : case CHARCELL : case INTCELL : + case BIGCELL : case FLOATCELL: case STRCELL : break; @@ -1302,11 +1290,12 @@ tidyHd: switch (whatIs(p=hd(maPats(ma)))) { return FALSE; case STRCELL : { String s = textToStr(textOf(p)); - for (p=NIL; *s!='\0'; ++s) + for (p=NIL; *s!='\0'; ++s) { if (*s!='\\' || *++s=='\\') p = ap(consChar(*s),p); else p = ap(consChar('\0'),p); + } hd(maPats(ma)) = revOnto(p,nameNil); } return FALSE; @@ -1411,10 +1400,6 @@ Cell d1, d2; { /* descriptors have same value */ return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2)); if (isFloat(arg(d1))) return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2)); -#if BIGNUMS - if (isBignum(arg(d1))) - return isBignum(arg(d2)) && bigCmp(arg(d1),arg(d2))==0; -#endif internal("eqNumDiscr"); return FALSE;/*NOTREACHED*/ } @@ -1452,7 +1437,7 @@ List binds; { static List addGlobals( List binds ) { - /* stgGlobals = pieces of code generated for selectors, tuples, etc */ + /* stgGlobals = list of top-level STG binds */ for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) { StgVar bind = snd(hd(stgGlobals)); if (nonNull(stgVarBody(bind))) { @@ -1462,6 +1447,15 @@ static List addGlobals( List binds ) return binds; } +typedef void (*sighandler_t)(int); +void eval_ctrlbrk ( int dunnowhat ) +{ + interruptStgRts(); + /* reinstall the signal handler so that further interrupts which + happen before the thread can return to the scheduler, lead back + here rather than invoking the previous break handler. */ + signal(SIGINT, eval_ctrlbrk); +} Void evalExp() { /* compile and run input expression */ /* ToDo: this name (and other names generated during pattern match?) @@ -1473,7 +1467,7 @@ Void evalExp() { /* compile and run input expression */ name(n).stgVar = v; compiler(RESET); e = pmcTerm(0,NIL,translate(inputExpr)); - stgDefn(n,0,e); //ppStg(name(n).stgVar); + stgDefn(n,0,e); inputExpr = NIL; stgCGBinds(addGlobals(singleton(v))); @@ -1481,10 +1475,19 @@ Void evalExp() { /* compile and run input expression */ /* Re-initialise the scheduler - ToDo: do I need this? */ initScheduler(); +#ifdef CRUDE_PROFILING + cp_init(); +#endif + /* ToDo: don't really initScheduler every time. fix */ { - HaskellObj result; /* ignored */ - SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result); + HaskellObj result; /* ignored */ + sighandler_t old_ctrlbrk; + SchedulerStatus status; + old_ctrlbrk = signal(SIGINT, eval_ctrlbrk); + assert(old_ctrlbrk != SIG_ERR); + status = rts_eval_(closureOfVar(v),10000,&result); + signal(SIGINT,old_ctrlbrk); switch (status) { case Deadlock: case AllBlocked: /* I don't understand the distinction - ADR */ @@ -1500,6 +1503,7 @@ Void evalExp() { /* compile and run input expression */ RevertCAFs(); break; case Success: + RevertCAFs(); break; default: internal("evalExp: Unrecognised SchedulerStatus"); @@ -1507,16 +1511,19 @@ Void evalExp() { /* compile and run input expression */ fflush(stdout); fflush(stderr); } +#ifdef CRUDE_PROFILING + cp_show(); +#endif + } -static List local addStgVar( List binds, Pair bind ); /* todo */ static List local addStgVar( List binds, Pair bind ) { StgVar nv = mkStgVar(NIL,NIL); Text t = textOf(fst(bind)); Name n = findName(t); - //printf ( "addStgVar %s\n", textToStr(t)); + if (isNull(n)) { /* Lookup global name - the only way*/ n = newName(t,NIL); /* this (should be able to happen) */ } /* is with new global var introduced*/ @@ -1561,7 +1568,7 @@ Void compileDefns() { /* compile script definitions */ } } - setGoal("Compiling",t); + setGoal("Translating",t); /* do valDefns before everything else so that all stgVar's get added. */ for (; nonNull(valDefns); valDefns=tl(valDefns)) { hd(valDefns) = transBinds(hd(valDefns)); @@ -1578,13 +1585,17 @@ Void compileDefns() { /* compile script definitions */ soFar(i++); } - /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */ binds = addGlobals(binds); + done(); #if USE_HUGS_OPTIMIZER -#error optimiser - if (lastModule() != modulePrelude) - mapProc(optimiseTopBind,binds); + if (optimise) { + t = length(binds); + setGoal("Simplifying",t); + optimiseTopBinds(binds); + done(); + } #endif + setGoal("Generating code",t); stgCGBinds(binds); done(); @@ -1596,20 +1607,6 @@ Pair bind; { List defs = snd(bind); Int arity = length(fst(hd(defs))); assert(isName(n)); - - //{ Cell cc; - // printf ( "compileGlobalFunction %s\n", textToStr(name(n).text)); - // cc = defs; - // while (nonNull(cc)) { - // printExp(stdout, fst(hd(cc))); - // printf ( "\n = " ); - // printExp(stdout, snd(hd(cc))); - // printf( "\n" ); - // cc = tl(cc); - // } - // printf ( "\n\n\n" ); - //} - compiler(RESET); stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs))); } @@ -1618,20 +1615,6 @@ static Void local compileGenFunction(n) /* Produce code for internally */ Name n; { /* generated function */ List defs = name(n).defn; Int arity = length(fst(hd(defs))); - - //{ Cell cc; - // printf ( "compileGenFunction %s\n", textToStr(name(n).text)); - // cc = defs; - // while (nonNull(cc)) { - // printExp(stdout, fst(hd(cc))); - // printf ( "\n = " ); - // printExp(stdout, snd(hd(cc))); - // printf( "\n" ); - // cc = tl(cc); - // } - // printf ( "\n\n\n" ); - //} - compiler(RESET); currentName = n; mapProc(transAlt,defs); diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 75b86a7..3c444bd 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -7,8 +7,8 @@ * in the distribution for details. * * $RCSfile: connect.h,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:05 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:06:50 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -73,27 +73,7 @@ extern Class classMonad; /* Monads */ extern Name nameReturn, nameBind; /* for translating monad comps */ extern Name nameMFail; extern Name nameListMonad; /* builder function for List Monad */ - -#if EVAL_INSTANCES -extern Name nameStrict, nameSeq; /* Members of class Eval */ -extern Name nameIStrict, nameISeq; /* ... and their implementations */ -#endif - extern Name namePrint; /* printing primitive */ - -#if IO_MONAD -extern Type typeProgIO; /* For the IO monad, IO () */ -extern Name nameIORun; /* IO monad executor */ -extern Name namePutStr; /* Prelude.putStr */ -extern Name nameUserErr; /* primitives required for IOError */ -extern Name nameNameErr, nameSearchErr; -#endif - -#if IO_HANDLES -extern Name nameWriteErr, nameIllegal;/* primitives required for IOError */ -extern Name nameEOFErr; -#endif - extern Text textPrelude; extern Text textNum; /* used to process default decls */ #if NPLUSK @@ -134,9 +114,6 @@ extern Class classShow; extern Class classRead; extern Class classIx; extern Class classEnum; -#if EVAL_INSTANCES -extern Class classEval; -#endif extern Class classBounded; extern Class classReal; /* `numeric' classes */ @@ -168,7 +145,6 @@ extern Int whnfArgs; /* number of args of term in whnf */ extern Cell whnfHead; /* head of term in whnf */ extern Int whnfInt; /* integer value of term in whnf */ extern Float whnfFloat; /* float value of term in whnf */ -/*ToDo?? extern Long numReductions;*/ /* number of reductions used */ extern Long numCells; /* number of cells allocated */ extern Int numGcs; /* number of garbage collections */ extern Bool broken; /* indicates interrupt received */ @@ -177,8 +153,7 @@ extern Bool preludeLoaded; /* TRUE => prelude has been loaded */ extern Bool gcMessages; /* TRUE => print GC messages */ extern Bool literateScripts; /* TRUE => default lit scripts */ extern Bool literateErrors; /* TRUE => report errs in lit scrs */ -/*ToDo?? extern Bool failOnError;*/ /* TRUE => error produces immediate*/ - /* termination */ +extern Bool optimise; /* TRUE => simplify STG */ extern Int cutoff; /* Constraint Cutoff depth */ @@ -204,6 +179,7 @@ extern Void everybody Args((Int)); #define INSTALL 3 /* install subsystem (executed once only) */ #define EXIT 4 /* Take action immediately before exit() */ #define BREAK 5 /* Take action after program break */ +#define GCDONE 6 /* Restore subsystem invariantss after GC */ typedef long Target; extern Void setGoal Args((String, Target)); @@ -228,21 +204,15 @@ extern String unlexChar Args((Char,Char)); extern Void printString Args((String)); extern Void substitution Args((Int)); +extern Void optimiser Args((Int)); extern Void staticAnalysis Args((Int)); -#if IGNORE_MODULES -#define startModule(m) doNothing() -#define setExportList(l) doNothing() -#define setExports(l) doNothing() -#define addQualImport(m,as) doNothing() -#define addUnqualImport(m,l) doNothing() -#else extern Void startModule Args((Cell)); extern Void setExportList Args((List)); extern Void setExports Args((List)); extern Void addQualImport Args((Text,Text)); extern Void addUnqualImport Args((Text,List)); -#endif + extern Void tyconDefn Args((Int,Cell,Cell,Cell)); extern Void setTypeIns Args((List)); extern Void clearTypeIns Args((Void)); @@ -252,9 +222,6 @@ extern Void ambigError Args((Int,String,Cell,Type)); extern Void classDefn Args((Int,Cell,Cell)); extern Void instDefn Args((Int,Cell,Cell)); extern Void addTupInst Args((Class,Int)); -#if EVAL_INSTANCES -extern Void addEvalInst Args((Int,Cell,Int,List)); -#endif #if TREX extern Inst addRecShowInst Args((Class,Ext)); extern Inst addRecEqInst Args((Class,Ext)); @@ -304,41 +271,11 @@ extern Void eval Args((Cell)); extern Cell evalWithNoError Args((Cell)); extern Void evalFails Args((StackPtr)); -#if BYTECODE_PRIMS -extern Int IntAt Args((Addr)); -#if !BREAK_FLOATS -extern Float FloatAt Args((Addr)); -#endif -extern Cell CellAt Args((Addr)); -extern Text TextAt Args((Addr)); -extern Addr AddrAt Args((Addr)); -extern Int InstrAt Args((Addr)); -#endif /* BYTECODE_PRIMS */ - extern Void abandon Args((String,Cell)); extern Void outputString Args((FILE *)); extern Void dialogue Args((Cell)); #define consChar(c) ap(nameCons,mkChar(c)) -#if BIGNUMS -extern Bignum bigInt Args((Int)); -extern Bignum bigDouble Args((double)); -extern Bignum bigNeg Args((Bignum)); -extern Cell bigToInt Args((Bignum)); -extern Cell bigToFloat Args((Bignum)); -extern Bignum bigStr Args((String)); -extern Cell bigOut Args((Bignum,Cell,Bool)); -extern Bignum bigShift Args((Bignum,Int,Int)); -extern Int bigCmp Args((Bignum,Bignum)); -#endif -#if IO_MONAD -extern Void setHugsArgs Args((Int,String[])); -#endif - -#if PROFILING -extern String timeString Args((Void)); -#endif - extern Int shellEsc Args((String)); extern Int getTerminalWidth Args((Void)); extern Void normalTerminal Args((Void)); @@ -557,4 +494,7 @@ extern Void unlexStrConst Args((Text)); extern Void unlexVar Args((Text)); extern List offsetTyvarsIn Args((Type,List)); +extern Void optimiseTopBinds Args((List)); extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ + +#define SMALL_INLINE_SIZE 9 diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c index d4dcdbd..26f26ec 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: derive.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:06 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:06:50 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -19,61 +19,6 @@ #include "Assembler.h" #include "link.h" -#if 0 -static Cell varTrue; -static Cell varFalse; -#if DERIVE_ORD -static Cell varCompAux; /* auxiliary function for compares */ -static Cell varCompare; -static Cell varEQ; -#endif -#if DERIVE_IX -static Cell varRangeSize; /* calculate size of index range */ -static Cell varInRange; -static Cell varRange; -static Cell varIndex; -static Cell varMult; -static Cell qvarPlus; -static Cell varMap; -static Cell qvarMinus; -static Cell varError; -#endif -#if DERIVE_ENUM -static Cell varToEnum; -static Cell varFromEnum; -static Cell varEnumFromTo; -static Cell varEnumFromThenTo; -#endif -#if DERIVE_BOUNDED -static Cell varMinBound; -static Cell varMaxBound; -#endif -#if DERIVE_SHOW - Cell conCons; -static Cell varShowField; /* display single field */ -static Cell varShowParen; /* wrap with parens */ -static Cell varCompose; /* function composition */ -static Cell varShowsPrec; -static Cell varLe; -#endif -#if DERIVE_READ -static Cell varReadField; /* read single field */ -static Cell varReadParen; /* unwrap from parens */ -static Cell varLex; /* lexer */ -static Cell varReadsPrec; -static Cell varGt; -#endif -#if DERIVE_SHOW || DERIVE_READ -static Cell varAppend; /* list append */ -#endif -#if DERIVE_EQ || DERIVE_IX -static Cell varAnd; /* built-in logical connectives */ -#endif -#if DERIVE_EQ || DERIVE_ORD -static Cell varEq; -#endif -#endif /* 0 */ - List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ /* -------------------------------------------------------------------------- @@ -83,14 +28,8 @@ List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ static List local getDiVars Args((Int)); static Cell local mkBind Args((String,List)); static Cell local mkVarAlts Args((Int,Cell)); - -#if DERIVE_EQ || DERIVE_ORD static List local makeDPats2 Args((Cell,Int)); -#endif -#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED static Bool local isEnumType Args((Tycon)); -#endif - static Pair local mkAltEq Args((Int,List)); static Pair local mkAltOrd Args((Int,List)); static Cell local prodRange Args((Int,List,Cell,Cell,Cell)); @@ -107,7 +46,6 @@ static Cell local mkReadRecord Args((Cell,List)); static List local mkBndBinds Args((Int,Cell,Int)); - /* -------------------------------------------------------------------------- * Deriving Utilities * ------------------------------------------------------------------------*/ @@ -135,7 +73,6 @@ Cell r; { return singleton(pair(NIL,pair(mkInt(line),r))); } -#if DERIVE_EQ || DERIVE_ORD static List local makeDPats2(h,n) /* generate pattern list */ Cell h; /* by putting two new patterns with*/ Int n; { /* head h and new var components */ @@ -156,9 +93,7 @@ Int n; { /* head h and new var components */ } return cons(p,vs); } -#endif -#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED static Bool local isEnumType(t) /* Determine whether t is an enumeration */ Tycon t; { /* type (i.e. all constructors arity == 0) */ if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) { @@ -173,7 +108,7 @@ Tycon t; { /* type (i.e. all constructors arity == 0) */ } return FALSE; } -#endif + /* -------------------------------------------------------------------------- * Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord) @@ -193,8 +128,6 @@ Tycon t; { /* type (i.e. all constructors arity == 0) */ * constructors in the datatype definition. * ------------------------------------------------------------------------*/ -#if DERIVE_EQ - static Pair local mkAltEq Args((Int,List)); List deriveEq(t) /* generate binding for derived == */ @@ -233,9 +166,7 @@ List pats; { /* arguments */ } return pair(pats,pair(mkInt(line),e)); } -#endif /* DERIVE_EQ */ -#if DERIVE_ORD static Pair local mkAltOrd Args((Int,List)); @@ -296,14 +227,12 @@ List pats; { /* arguments */ return pair(pats,pair(mkInt(line),e)); } -#endif /* DERIVE_ORD */ /* -------------------------------------------------------------------------- * Deriving Ix and Enum: * ------------------------------------------------------------------------*/ -#if DERIVE_ENUM List deriveEnum(t) /* Construct definition of enumeration */ Tycon t; { Int l = tycon(t).line; @@ -336,9 +265,8 @@ Tycon t; { /* default instance of enumFromThenTo is good */ NIL)))); } -#endif /* DERIVE_ENUM */ -#if DERIVE_IX + static List local mkIxBindsEnum Args((Tycon)); static List local mkIxBinds Args((Int,Cell,Int)); static Cell local prodRange Args((Int,List,Cell,Cell,Cell)); @@ -489,7 +417,6 @@ Cell ls, us, is; { e = singleton(pair(pats,pair(mkInt(line),e))); return mkBind("inRange",e); } -#endif /* DERIVE_IX */ /* -------------------------------------------------------------------------- @@ -920,8 +847,6 @@ List fs; { * Deriving Bounded: * ------------------------------------------------------------------------*/ -#if DERIVE_BOUNDED - List deriveBounded(t) /* construct definition of bounds */ Tycon t; { if (isEnumType(t)) { @@ -960,8 +885,6 @@ Int n; { cons(mkBind("maxBound",mkVarAlts(line,maxB)), NIL)); } -#endif /* DERIVE_BOUNDED */ - /* -------------------------------------------------------------------------- @@ -998,6 +921,7 @@ Tycon t; { name(nm).arity = 1; name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)), NIL); + name(nm).stgSize = stgSize(stgVarBody(name(nm).stgVar)); tycon(t).conToTag = nm; /* hack to make it print out */ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); @@ -1008,7 +932,6 @@ Tycon t; { Void implementTagToCon(t) Tycon t; { if (isNull(tycon(t).tagToCon)) { - String etxt; String tyconname; List cs; Name nm; @@ -1019,6 +942,7 @@ Tycon t; { StgVar bind2; StgVar bind3; List alts; + char etxt[200]; assert(nameMkA); assert(nameUnpackString); @@ -1027,8 +951,9 @@ Tycon t; { || tycon(t).what==NEWTYPE)); tyconname = textToStr(tycon(t).text); - etxt = malloc(100+strlen(tyconname)); - assert(etxt); + if (strlen(tyconname) > 100) + internal("implementTagToCon: tycon name too long"); + sprintf(etxt, "out-of-range arg for `toEnum' " "in derived `instance Enum %s'", @@ -1076,10 +1001,10 @@ Tycon t; { mkStgPrimCase(v2,alts))))), NIL ); + name(nm).stgSize = stgSize(stgVarBody(name(nm).stgVar)); tycon(t).tagToCon = nm; /* hack to make it print out */ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); - if (etxt) free(etxt); } } @@ -1090,131 +1015,18 @@ Tycon t; { Void deriveControl(what) Int what; { - Text textPrelude = findText("Prelude"); switch (what) { case INSTALL : -#if 0 - varTrue = mkQVar(textPrelude,findText("True")); - varFalse = mkQVar(textPrelude,findText("False")); -#if DERIVE_ORD - varCompAux = mkQVar(textPrelude,findText("primCompAux")); - varCompare = mkQVar(textPrelude,findText("compare")); - varEQ = mkQVar(textPrelude,findText("EQ")); -#endif -#if DERIVE_IX - varRangeSize = mkQVar(textPrelude,findText("rangeSize")); - varInRange = mkQVar(textPrelude,findText("inRange")); - varRange = mkQVar(textPrelude,findText("range")); - varIndex = mkQVar(textPrelude,findText("index")); - varMult = mkQVar(textPrelude,findText("*")); - qvarPlus = mkQVar(textPrelude,findText("+")); - varMap = mkQVar(textPrelude,findText("map")); - qvarMinus = mkQVar(textPrelude,findText("-")); - varError = mkQVar(textPrelude,findText("error")); -#endif -#if DERIVE_ENUM - varToEnum = mkQVar(textPrelude,findText("toEnum")); - varFromEnum = mkQVar(textPrelude,findText("fromEnum")); - varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo")); - varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo")); -#endif -#if DERIVE_BOUNDED - varMinBound = mkQVar(textPrelude,findText("minBound")); - varMaxBound = mkQVar(textPrelude,findText("maxBound")); -#endif -#if DERIVE_SHOW - conCons = mkQCon(textPrelude,findText(":")); - varShowField = mkQVar(textPrelude,findText("primShowField")); - varShowParen = mkQVar(textPrelude,findText("showParen")); - varCompose = mkQVar(textPrelude,findText(".")); - varShowsPrec = mkQVar(textPrelude,findText("showsPrec")); - varLe = mkQVar(textPrelude,findText("<=")); -#endif -#if DERIVE_READ - varReadField = mkQVar(textPrelude,findText("primReadField")); - varReadParen = mkQVar(textPrelude,findText("readParen")); - varLex = mkQVar(textPrelude,findText("lex")); - varReadsPrec = mkQVar(textPrelude,findText("readsPrec")); - varGt = mkQVar(textPrelude,findText(">")); -#endif -#if DERIVE_SHOW || DERIVE_READ - varAppend = mkQVar(textPrelude,findText("++")); -#endif -#if DERIVE_EQ || DERIVE_IX - varAnd = mkQVar(textPrelude,findText("&&")); -#endif -#if DERIVE_EQ || DERIVE_ORD - varEq = mkQVar(textPrelude,findText("==")); -#endif -#endif /* 0 */ /* deliberate fall through */ case RESET : diVars = NIL; diNum = 0; -#if DERIVE_SHOW | DERIVE_READ cfunSfuns = NIL; -#endif break; case MARK : mark(diVars); -#if DERIVE_SHOW | DERIVE_READ mark(cfunSfuns); -#endif -#if 0 - mark(varTrue); - mark(varFalse); -#if DERIVE_ORD - mark(varCompAux); - mark(varCompare); - mark(varEQ); -#endif -#if DERIVE_IX - mark(varRangeSize); - mark(varInRange); - mark(varRange); - mark(varIndex); - mark(varMult); - mark(qvarPlus); - mark(varMap); - mark(qvarMinus); - mark(varError); -#endif -#if DERIVE_ENUM - mark(varToEnum); - mark(varFromEnum); - mark(varEnumFromTo); - mark(varEnumFromThenTo); -#endif -#if DERIVE_BOUNDED - mark(varMinBound); - mark(varMaxBound); -#endif -#if DERIVE_SHOW - mark(conCons); - mark(varShowField); - mark(varShowParen); - mark(varCompose); - mark(varShowsPrec); - mark(varLe); -#endif -#if DERIVE_READ - mark(varReadField); - mark(varReadParen); - mark(varLex); - mark(varReadsPrec); - mark(varGt); -#endif -#if DERIVE_SHOW || DERIVE_READ - mark(varAppend); -#endif -#if DERIVE_EQ || DERIVE_IX - mark(varAnd); -#endif -#if DERIVE_EQ || DERIVE_ORD - mark(varEq); -#endif -#endif /* 0 */ break; } } diff --git a/ghc/interpreter/free.c b/ghc/interpreter/free.c index 59eb322..d58635b 100644 --- a/ghc/interpreter/free.c +++ b/ghc/interpreter/free.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: free.c,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:29 $ + * $Revision: 1.4 $ + * $Date: 1999/04/27 10:06:52 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -72,17 +72,18 @@ List freeVarsBind( List acc, StgVar v ) static List freeVarsAlt( List acc, StgCaseAlt alt ) { - StgPat pat = stgCaseAltPat(alt); - acc = freeVarsExpr(acc,stgCaseAltBody(alt)); - if (!isDefaultPat(pat)) { - acc = diffList(acc,stgPatVars(pat)); + if (isDefaultAlt(alt)) { + acc = freeVarsExpr(acc,stgDefaultBody(alt)); + return deleteCell(acc,stgDefaultVar(alt)); + } else { + acc = freeVarsExpr(acc,stgCaseAltBody(alt)); + return diffList(acc,stgCaseAltVars(alt)); } - return deleteCell(acc,pat); } static List freeVarsPrimAlt( List acc, StgPrimAlt alt ) { - List vs = stgPrimAltPats(alt); + List vs = stgPrimAltVars(alt); acc = freeVarsExpr(acc,stgPrimAltBody(alt)); return diffList(acc,vs); } @@ -115,6 +116,9 @@ static List freeVarsExpr( List acc, StgExpr e ) case NAME: return acc; /* Names are never free vars */ default: +printf("\n\n"); +ppStgExpr(e); +printf("\n"); internal("freeVarsExpr"); } } diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index ade1335..b9268d6 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: hugs.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:07 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:06:52 $ * ------------------------------------------------------------------------*/ #include @@ -52,12 +52,8 @@ static Void local editor Args((Void)); static Void local find Args((Void)); static Bool local startEdit Args((Int,String)); static Void local runEditor Args((Void)); -#if IGNORE_MODULES -#define findEvalModule() doNothing() -#else static Void local setModule Args((Void)); static Module local findEvalModule Args((Void)); -#endif static Void local evaluator Args((Void)); static Void local stopAnyPrinting Args((Void)); static Void local showtype Args((Void)); @@ -108,6 +104,8 @@ static Bool addType = FALSE; /* TRUE => print type with value */ static Bool chaseImports = TRUE; /* TRUE => chase imports on load */ static Bool useDots = RISCOS; /* TRUE => use dots in progress */ static Bool quiet = FALSE; /* TRUE => don't show progress */ + Bool preludeLoaded = FALSE; + Bool optimise = TRUE; static String scriptName[NUM_SCRIPTS]; /* Script file names */ static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */ @@ -121,13 +119,13 @@ static Text evalModule = 0; /* Name of module we eval exprs in */ static String currProject = 0; /* Name of current project file */ static Bool projectLoaded = FALSE; /* TRUE => project file loaded */ +static Bool autoMain = FALSE; static String lastEdit = 0; /* Name of script to edit (if any) */ static Int lastEdLine = 0; /* Editor line number (if possible)*/ static String prompt = 0; /* Prompt string */ static Int hpSize = DEFAULTHEAP; /* Desired heap size */ String hugsEdit = 0; /* String for editor command */ String hugsPath = 0; /* String for file search path */ -Bool preludeLoaded = FALSE; #if REDIRECT_OUTPUT static Bool disableOutput = FALSE; /* redirect output to buffer? */ @@ -163,6 +161,13 @@ char *argv[]; { CStackBase = &argc; /* Save stack base for use in gc */ + /* If first arg is +Q or -Q, be entirely silent, and automatically run + main after loading scripts. Useful for running the nofib suite. */ + if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) { + autoMain = TRUE; + hugsEnableOutput(0); + } + Printf("__ __ __ __ ____ ___ _______________________________________________\n"); Printf("|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system\n"); Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n"); @@ -194,7 +199,8 @@ static Void local initialize(argc,argv)/* Interpreter initialization */ Int argc; String argv[]; { Script i; - String proj = 0; + String proj = 0; + char argv_0_orig[1000]; setLastEdit((String)0,0); lastEdit = 0; @@ -218,10 +224,12 @@ String argv[]; { #endif /* USE_REGISTRY */ readOptions(fromEnv("STGHUGSFLAGS","")); - startupHaskell ( argc, argv ); + strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */ + startupHaskell (argc,argv); argc = prog_argc; argv = prog_argv; for (i=1; i reductions\n"); -#endif Printf("\nCurrent settings: "); togglesIn(TRUE); @@ -349,9 +354,6 @@ ToDo Printf("\nPreprocessor : -F"); printString(preprocessor); #endif -#if PROFILING - Printf("\nProfile interval: -d%d", profiling ? profInterval : 0); -#endif Printf("\nCompatibility : %s", haskell98 ? "Haskell 98" : "Hugs Extensions"); Putchar('\n'); @@ -410,9 +412,6 @@ static String local optionsToStr() { /* convert options to string */ #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN)) PUTStr('F',preprocessor); #endif -#if PROFILING - PUTInt('d',profiling ? profInterval : 0); -#endif PUTC('\0'); return buffer; } @@ -450,6 +449,8 @@ String s; { /* return FALSE if none found. */ while (*++s) switch (*s) { + case 'Q' : break; /* already handled */ + case 'p' : if (s[1]) { if (prompt) free(prompt); prompt = strCopy(s+1); @@ -594,9 +595,8 @@ static struct cmd cmds[] = { {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT}, {":quit", QUIT}, {":set", SET}, {":find", FIND}, {":names", NAMES}, {":info", INFO}, {":project", PROJECT}, -#if !IGNORE_MODULES + {":dump", DUMP}, {":ztats", STATS}, {":module",SETMODULE}, -#endif {"", EVAL}, {0,0} }; @@ -611,9 +611,7 @@ static Void local menu() { Printf(":project use project file\n"); Printf(":edit edit file\n"); Printf(":edit edit last module\n"); -#if !IGNORE_MODULES Printf(":module set module for evaluating expressions\n"); -#endif Printf(" evaluate expression\n"); Printf(":type print type of expression\n"); Printf(":? display this list of commands\n"); @@ -625,6 +623,10 @@ static Void local menu() { Printf(":!command shell escape\n"); Printf(":cd dir change directory\n"); Printf(":gc force garbage collection\n"); + Printf(":dump print STG code for named fn\n"); +#ifdef CRUDE_PROFILING + Printf(":ztats print reduction stats\n"); +#endif Printf(":quit exit Hugs interpreter\n"); } @@ -654,6 +656,7 @@ struct options toggle[] = { /* List of command line toggles */ {'k', "Show kind errors in full", &kindExpert}, {'o', "Allow overlapping instances", &allowOverlap}, {'i', "Chase imports while loading modules", &chaseImports}, + {'O', "Optimise (improve?) generated code", &optimise}, #if DEBUG_CODE {'D', "Debug: show generated code", &debugCode}, #endif @@ -975,7 +978,6 @@ Int line; { * Read and evaluate an expression: * ------------------------------------------------------------------------*/ -#if !IGNORE_MODULES static Void local setModule(){/*set module in which to evaluate expressions*/ String s = readFilename(); if (!s) s = ""; /* :m clears the current module selection */ @@ -989,7 +991,6 @@ static Module local findEvalModule() { /*Module in which to eval expressions*/ m = lastModule(); return m; } -#endif static Void local evaluator() { /* evaluate expr and print value */ Type type, bd; @@ -1018,13 +1019,6 @@ static Void local evaluator() { /* evaluate expr and print value */ EEND; } -#if PROFILING - if (profiling) - profilerLog("profile.hp"); - numReductions = 0; - garbageCollect(); -#endif - #ifdef WANT_TIMER updateTimers(); #endif @@ -1043,9 +1037,6 @@ static Void local evaluator() { /* evaluate expr and print value */ ERRTEXT "\n" EEND; } - //inputExpr = ap2(namePrint,d,inputExpr); - //inputExpr = ap(nameRunIO,inputExpr); - inputExpr = ap2(findName(findText("show")),d,inputExpr); inputExpr = ap(findName(findText("putStr")), inputExpr); inputExpr = ap(nameRunIO, inputExpr); @@ -1075,7 +1066,6 @@ static Void local stopAnyPrinting() { /* terminate printing of expression,*/ Putchar('\n'); if (showStats) { #define plural(v) v, (v==1?"":"s") - /* Printf("(%lu reduction%s, ",plural(numReductions)); */ Printf("%lu cell%s",plural(numCells)); if (numGcs>0) Printf(", %u garbage collection%s",plural(numGcs)); @@ -1166,6 +1156,58 @@ Cell c; { #endif } +extern Name nameHw; + +static Void local dumpStg() { /* print STG stuff */ + String s; + Text t; + Name n; + Int i; + Cell v; /* really StgVar */ + setCurrModule(findEvalModule()); + startNewScript(0); + for (; (s=readFilename())!=0;) { + t = findText(s); + v = n = NIL; + /* find the name while ignoring module scopes */ + for (i=NAMEMIN; i= 3 && + s[0]=='i' && s[1]=='d' && isdigit(s[2])) { + v = 0; + i = 2; + while (isdigit(s[i])) { + v = v * 10 + (s[i]-'0'); + i++; + } + v = -v; + n = nameFromStgVar(v); + } + + if (isNull(n) && whatIs(v)==STGVAR) { + Printf ( "\n{- `%s' has no nametable entry -}\n", s ); + Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(v))); + printStg(stderr, v ); + } else + if (isNull(n)) { + Printf ( "Unknown reference `%s'\n", s ); + } else + if (!isName(n)) { + Printf ( "Not a Name: `%s'\n", s ); + } else + if (isNull(name(n).stgVar)) { + Printf ( "Doesn't have a STG tree: %s\n", s ); + } else { + printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar); + Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(name(n).stgVar))); + printStg(stderr, name(n).stgVar); + } + } +} + static Void local info() { /* describe objects */ Int count = 0; /* or give menu of commands */ String s; @@ -1427,7 +1469,9 @@ String moduleName; { internal("Combined prompt and evaluation module name too long"); } #endif - consoleInput(promptBuffer); + if (autoMain) + stringInput("main\0"); else + consoleInput(promptBuffer); } /* -------------------------------------------------------------------------- @@ -1441,6 +1485,11 @@ Int argc; String argv[]; { Int errorNumber = setjmp(catch_error); + if (errorNumber && autoMain) { + fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" ); + exit(1); + } + breakOn(TRUE); /* enable break trapping */ if (numScripts==0) { /* only succeeds on first time, */ if (errorNumber) /* before prelude has been loaded */ @@ -1478,11 +1527,9 @@ String argv[]; { break; case PROJECT: project(); break; -#if !IGNORE_MODULES case SETMODULE : setModule(); break; -#endif case EVAL : evaluator(); break; case TYPEOF : showtype(); @@ -1495,6 +1542,11 @@ String argv[]; { break; case SET : set(); break; + case STATS: +#ifdef CRUDE_PROFILING + cp_show(); +#endif + break; case SYSTEM : if (shellEsc(readLine())) Printf("Warning: Shell escape terminated abnormally\n"); break; @@ -1502,6 +1554,8 @@ String argv[]; { break; case INFO : info(); break; + case DUMP : dumpStg(); + break; case QUIT : return; case COLLECT: consGC = FALSE; garbageCollect(); @@ -1516,6 +1570,7 @@ String argv[]; { Printf("Elapsed time (ms): %ld (user), %ld (system)\n", millisecs(userElapsed), millisecs(systElapsed)); #endif + if (autoMain) break; } breakOn(FALSE); } @@ -1878,6 +1933,7 @@ Int what; { /* system to respond as appropriate ... */ typeChecker(what); compiler(what); codegen(what); + optimiser(what); } /* -------------------------------------------------------------------------- @@ -1887,6 +1943,3 @@ Int what; { /* system to respond as appropriate ... */ #if HUGS_FOR_WINDOWS #include "winhugs.c" #endif - -/*-------------------------------------------------------------------------*/ - diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index 3d8c30c..cc11551 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: input.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:46 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:06:53 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -102,6 +102,10 @@ static Int local repeatLast Args((Void)); static Void local parseInput Args((Int)); +static Bool local doesNotExceed Args((String,Int,Int)); +static Int local stringToInt Args((String,Int)); + + /* -------------------------------------------------------------------------- * Text values for reserved words and special symbols: * ------------------------------------------------------------------------*/ @@ -667,47 +671,64 @@ static Text local readIdent() { /* read identifier */ return findText(tokenStr); } + +static Bool local doesNotExceed(s,radix,limit) +String s; +Int radix; +Int limit; { + Int n = 0; + Int p = 0; + while (TRUE) { + if (s[p] == 0) return TRUE; + if (overflows(n,radix,s[p]-'0',limit)) return FALSE; + n = radix*n + (s[p]-'0'); + p++; + } +} + +static Int local stringToInt(s,radix) +String s; +Int radix; { + Int n = 0; + Int p = 0; + while (TRUE) { + if (s[p] == 0) return n; + n = radix*n + (s[p]-'0'); + p++; + } +} + static Cell local readRadixNumber(r) /* Read literal in specified radix */ Int r; { /* from input of the form 0c{digs} */ Int d; + startToken(); skip(); /* skip leading zero */ - if ((d=readHexDigit(c1))<0 || d>=r)/* Special case; no digits, lex as */ - return mkInt(0); /* if it had been written "0 c..." */ - else { - Int n = 0; -#if BIGNUMS - Cell big = NIL; -#endif + if ((d=readHexDigit(c1))<0 || d>=r) { + /* Special case; no digits, lex as */ + /* if it had been written "0 c..." */ + saveTokenChar('0'); + } else { skip(); do { -#if BIGNUMS - if (nonNull(big)) - big = bigShift(big,d,r); - else if (overflows(n,r,d,MAXPOSINT)) - big = bigShift(bigInt(n),d,r); - else -#else - if (overflows(n,r,d,MAXPOSINT)) { - ERRMSG(row) "Integer literal out of range" - EEND; - } - else -#endif - n = r*n + d; + saveTokenChar('0'+readHexDigit(c0)); skip(); d = readHexDigit(c0); } while (d>=0 && d (a,a) -> [(a,b)] -> Array a b -array ixs@(ix_start, ix_end) ivs = runST (do +array ixs@(ix_start, ix_end) ivs = primRunST (do { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs ; arr <- primUnsafeFreezeArray mut_arr diff --git a/ghc/interpreter/lib/IO.hs b/ghc/interpreter/lib/IO.hs new file mode 100644 index 0000000..3c8c3d2 --- /dev/null +++ b/ghc/interpreter/lib/IO.hs @@ -0,0 +1,255 @@ + +----------------------------------------------------------------------------- +-- Standard Library: IO operations, beyond those included in the prelude +-- +-- WARNING: The names and semantics of functions defined in this module +-- may change as the details of the IO standard are clarified. +-- +-- WARNING: extremely kludgey, incomplete and just plain wrong. +----------------------------------------------------------------------------- + +module IO ( +-- Handle, HandlePosn, + Handle, +-- IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), + IOMode(ReadMode,WriteMode,AppendMode), + BufferMode(NoBuffering,LineBuffering,BlockBuffering), + SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), + stdin, stdout, stderr, + openFile, hClose, +-- hFileSize, hIsEOF, isEOF, +-- hSetBuffering, hGetBuffering, hFlush, + hFlush, + hGetPosn, hSetPosn, +-- hSeek, hIsSeekable, +-- hReady, hGetChar, hLookAhead, hGetContents, + hGetChar, hGetLine, hGetContents, + hPutChar, hPutStr, hPutStrLn, hPrint, + hIsOpen, hIsClosed, hIsReadable, hIsWritable, + isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, + isFullError, isEOFError, + isIllegalOperation, isPermissionError, isUserError, + ioeGetErrorString, ioeGetHandle, ioeGetFileName, + try, bracket, bracket_, + + -- ... and what the Prelude exports + IO, + FilePath, IOError, ioError, userError, catch, + putChar, putStr, putStrLn, print, + getChar, getLine, getContents, interact, + readFile, writeFile, appendFile, readIO, readLn + ) where + +import Ix(Ix) + +unimp :: String -> a +unimp s = error ("function not implemented: " ++ s) + +type FILE_STAR = Int +type Ptr = Int +nULL = 0 :: Int + +data Handle + = Handle { name :: FilePath, + file :: FILE_STAR, -- C handle + state :: HState, -- open/closed/semiclosed + mode :: IOMode, + --seekable :: Bool, + bmode :: BufferMode, + buff :: Ptr, + buffSize :: Int + } + +instance Eq Handle where + h1 == h2 = file h1 == file h2 + +instance Show Handle where + showsPrec _ h = showString ("<>") + +data HandlePosn + = HandlePosn + deriving (Eq, Show) + + +data IOMode = ReadMode | WriteMode | AppendMode + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data BufferMode = NoBuffering | LineBuffering + | BlockBuffering + deriving (Eq, Ord, Read, Show) + +data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data HState = HOpen | HSemiClosed | HClosed + deriving Eq + +stdin = Handle "stdin" (primRunST nh_stdin) HOpen ReadMode NoBuffering nULL 0 +stdout = Handle "stdout" (primRunST nh_stdout) HOpen WriteMode LineBuffering nULL 0 +stderr = Handle "stderr" (primRunST nh_stderr) HOpen WriteMode NoBuffering nULL 0 + +openFile :: FilePath -> IOMode -> IO Handle +openFile f mode + = copy_String_to_cstring f >>= \nameptr -> + nh_open nameptr (mode2num mode) >>= \fh -> + nh_free nameptr >> + if fh == nULL + then (ioError.IOError) ("openFile: can't open " ++ f ++ " in " ++ show mode) + else return (Handle f fh HOpen mode BlockBuffering nULL 0) + where + mode2num :: IOMode -> Int + mode2num ReadMode = 0 + mode2num WriteMode = 1 + mode2num AppendMode = 2 + +hClose :: Handle -> IO () +hClose h + | not (state h == HOpen) + = (ioError.IOError) ("hClose on non-open handle " ++ show h) + | otherwise + = nh_close (file h) >> + nh_errno >>= \err -> + if err == 0 + then return () + else (ioError.IOError) ("hClose: error closing " ++ name h) + +hFileSize :: Handle -> IO Integer +hFileSize = unimp "IO.hFileSize" +hIsEOF :: Handle -> IO Bool +hIsEOF = unimp "IO.hIsEOF" +isEOF :: IO Bool +isEOF = hIsEOF stdin + +hSetBuffering :: Handle -> BufferMode -> IO () +hSetBuffering = unimp "IO.hSetBuffering" +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering = unimp "IO.hGetBuffering" + +hFlush :: Handle -> IO () +hFlush h + = if state h /= HOpen + then (ioError.IOError) ("hFlush on closed/semiclosed file " ++ name h) + else nh_flush (file h) + +hGetPosn :: Handle -> IO HandlePosn +hGetPosn = unimp "IO.hGetPosn" +hSetPosn :: HandlePosn -> IO () +hSetPosn = unimp "IO.hSetPosn" +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek = unimp "IO.hSeek" +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput = unimp "hWaitForInput" +hReady :: Handle -> IO Bool +hReady h = hWaitForInput h 0 + +hGetChar :: Handle -> IO Char +hGetChar h + = nh_read (file h) >>= \ci -> + return (primIntToChar ci) + +hGetLine :: Handle -> IO String +hGetLine h = do c <- hGetChar h + if c=='\n' then return "" + else do cs <- hGetLine h + return (c:cs) + +hLookAhead :: Handle -> IO Char +hLookAhead = unimp "IO.hLookAhead" + +hGetContents :: Handle -> IO String +hGetContents h + | not (state h == HOpen && mode h == ReadMode) + = (ioError.IOError) ("hGetContents on invalid handle " ++ show h) + | otherwise + = read_all (file h) + where + read_all f + = unsafeInterleaveIO ( + nh_read f >>= \ci -> + if ci == -1 + then hClose h >> return [] + else read_all f >>= \rest -> + return ((primIntToChar ci):rest) + ) + +hPutStr :: Handle -> String -> IO () +hPutStr h s + | not (state h == HOpen && mode h /= ReadMode) + = (ioError.IOError) ("hPutStr on invalid handle " ++ show h) + | otherwise + = write_all (file h) s + where + write_all f [] + = return () + write_all f (c:cs) + = nh_write f (primCharToInt c) >> + write_all f cs + +hPutChar :: Handle -> Char -> IO () +hPutChar h c = hPutStr h [c] + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h s = do { hPutStr h s; hPutChar h '\n' } + +hPrint :: Show a => Handle -> a -> IO () +hPrint h = hPutStrLn h . show + +hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool +hIsOpen h = return (state h == HOpen) +hIsClosed h = return (state h == HClosed) +hIsReadable h = return (mode h == ReadMode) +hIsWritable h = return (mode h == WriteMode) + +hIsSeekable :: Handle -> IO Bool +hIsSeekable = unimp "IO.hIsSeekable" + +isIllegalOperation, + isAlreadyExistsError, + isDoesNotExistError, + isAlreadyInUseError, + isFullError, + isEOFError, + isPermissionError, + isUserError :: IOError -> Bool + +isIllegalOperation = unimp "IO.isIllegalOperation" +isAlreadyExistsError = unimp "IO.isAlreadyExistsError" +isDoesNotExistError = unimp "IO.isDoesNotExistError" +isAlreadyInUseError = unimp "IO.isAlreadyInUseError" +isFullError = unimp "IO.isFullError" +isEOFError = unimp "IO.isEOFError" +isPermissionError = unimp "IO.isPermissionError" +isUserError = unimp "IO.isUserError" + + +ioeGetErrorString :: IOError -> String +ioeGetErrorString = unimp "ioeGetErrorString" +ioeGetHandle :: IOError -> Maybe Handle +ioeGetHandle = unimp "ioeGetHandle" +ioeGetFileName :: IOError -> Maybe FilePath +ioeGetFileName = unimp "ioeGetFileName" + +try :: IO a -> IO (Either IOError a) +try p = catch (p >>= (return . Right)) (return . Left) + +bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +bracket before after m = do + x <- before + rs <- try (m x) + after x + case rs of + Right r -> return r + Left e -> ioError e + +-- variant of the above where middle computation doesn't want x +bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c +bracket_ before after m = do + x <- before + rs <- try m + after x + case rs of + Right r -> return r + Left e -> ioError e + +----------------------------------------------------------------------------- + diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index a034776..d7cb719 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -102,7 +102,17 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) - ,primCompAux + ,trace + -- Arrrggghhh!!! Help! Help! Help! + -- What?! Prelude.hs doesn't even _define_ most of these things! + ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray + ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv + ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open + ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar + ,unsafeInterleaveIO,nh_write,primCharToInt + + -- ToDo: rm -- these are only for debugging + ,primPlusInt,primEqChar,primRunIO ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -696,7 +706,7 @@ instance Integral Int where instance Integral Integer where quotRem = primQuotRemInteger - divMod = primDivModInteger + --divMod = primDivModInteger toInteger = id toInt = primIntegerToInt @@ -738,7 +748,7 @@ numericEnumFrom n = n : (numericEnumFrom $! (n+1)) numericEnumFromThen n m = iterate ((m-n)+) n numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n) numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n') - where p | n' > n = (<= m) + where p | n' >= n = (<= m) | otherwise = (>= m) instance Read Int where @@ -755,6 +765,7 @@ instance Read Integer where instance Show Integer where showsPrec = showSigned showInt + -- Standard Floating types -------------------------------------------------- data Float -- builtin datatype of single precision floating point numbers @@ -922,16 +933,14 @@ instance Read Float where readsPrec p = readSigned readFloat instance Show Float where - showsPrec p = showFloat - --error "should call showFloat" + showsPrec p = showSigned showFloat p instance Read Double where readsPrec p = readSigned readFloat --- Note that showFloat in Numeric isn't used here instance Show Double where - showsPrec p = showFloat - --error "should call showFloat" + showsPrec p = showSigned showFloat p + -- Some standard functions -------------------------------------------------- @@ -1446,11 +1455,20 @@ readInt radix isDig digToInt s = -- showInt is used for positive numbers only showInt :: Integral a => a -> ShowS -showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers" - | otherwise = - let (n',d) = quotRem n 10 - r' = toEnum (fromEnum '0' + fromIntegral d) : r - in if n' == 0 then r' else showInt n' r' +showInt n r + | n < 0 + = error "Numeric.showInt: can't show negative numbers" + | otherwise +{- + = let (n',d) = quotRem n 10 + r' = toEnum (fromEnum '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' +-} + = case quotRem n 10 of { (n',d) -> + let r' = toEnum (fromEnum '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' + } + readSigned:: Real a => ReadS a -> ReadS a readSigned readPos = readParen False read' @@ -1501,9 +1519,6 @@ primPmFlt n x = fromDouble n == x -- ToDo: make the message more informative. primPmFail :: a primPmFail = error "Pattern Match Failure" -primPmFailBUG :: a -primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++ - "**Please** report to v-julsew@microsoft.com. Thx!\n") -- used in desugaring Foreign functions primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a @@ -1555,10 +1570,11 @@ userError :: String -> IOError userError s = primRaise (ErrorCall s) catch :: IO a -> (IOError -> IO a) -> IO a -catch x eh = primCatch x (eh.exception2ioerror) - where - exception2ioerror (IOExcept s) = IOError s - exception2ioerror other = IOError (show other) +catch m k + = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s) + where + e2ioe (IOExcept s) = IOError s + e2ioe other = IOError (show other) putChar :: Char -> IO () putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c) @@ -1597,7 +1613,7 @@ interact f = getContents >>= (putStr . f) readFile :: FilePath -> IO String readFile fname - = fileopen_sendname fname >>= \ptr -> + = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 0 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> @@ -1607,7 +1623,7 @@ readFile fname writeFile :: FilePath -> String -> IO () writeFile fname contents - = fileopen_sendname fname >>= \ptr -> + = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 1 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> @@ -1618,7 +1634,7 @@ writeFile fname contents appendFile :: FilePath -> String -> IO () appendFile fname contents - = fileopen_sendname fname >>= \ptr -> + = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 2 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> @@ -1653,27 +1669,47 @@ instance Show Exception where data IOResult = IOResult deriving (Show) -type FILE_STAR = Int +type FILE_STAR = Int -- FILE * +type Ptr = Int -- char * foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR +foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR +foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int -foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int -foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO () -foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int - -fileopen_sendname :: String -> IO Int -fileopen_sendname fname - = nh_malloc (1 + length fname) >>= \ptr -> - let loop i [] = nh_assign ptr i 0 >> return ptr - loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs +foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr +foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO () +foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO () +foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int + +foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int +foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int +foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr + +copy_String_to_cstring :: String -> IO Ptr +copy_String_to_cstring s + = nh_malloc (1 + length s) >>= \ptr0 -> + let loop ptr [] = nh_store ptr 0 >> return ptr0 + loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") ( + nh_store ptr (primCharToInt c) >> loop (ptr+1) cs + --) in - loop 0 fname + loop ptr0 s + +copy_cstring_to_String :: Ptr -> IO String +copy_cstring_to_String ptr + = nh_load ptr >>= \ci -> + if ci == 0 + then return [] + else copy_cstring_to_String (ptr+1) >>= \cs -> + --trace ("In " ++ show ci) ( + return ((primIntToChar ci) : cs) + --) readfromhandle :: FILE_STAR -> IO String readfromhandle h @@ -1694,6 +1730,31 @@ writetohandle fname h (c:cs) = nh_write h (primCharToInt c) >> writetohandle fname h cs +primGetRawArgs :: IO [String] +primGetRawArgs + = nh_argc >>= \argc -> + accumulate (map (get_one_arg 0) [0 .. argc-1]) + where + get_one_arg :: Int -> Int -> IO String + get_one_arg offset argno + = nh_argvb argno offset >>= \cb -> + if cb == 0 + then return [] + else get_one_arg (offset+1) argno >>= \s -> + return ((primIntToChar cb):s) + +primGetEnv :: String -> IO String +primGetEnv v + = copy_String_to_cstring v >>= \ptr -> + nh_getenv ptr >>= \ptr2 -> + nh_free ptr >> + if ptr2 == 0 + then return [] + else + copy_cstring_to_String ptr2 >>= \result -> + return result + + ------------------------------------------------------------------------------ -- ST, IO -------------------------------------------------------------------- ------------------------------------------------------------------------------ @@ -1704,12 +1765,12 @@ data RealWorld type IO a = ST RealWorld a ---runST :: (forall s. ST s a) -> a -runST :: ST RealWorld a -> a -runST m = fst (unST m theWorld) +--primRunST :: (forall s. ST s a) -> a +primRunST :: ST RealWorld a -> a +primRunST m = fst (unST m theWorld) where theWorld :: RealWorld - theWorld = error "runST: entered the RealWorld" + theWorld = error "primRunST: entered the RealWorld" unST (ST a) = a @@ -1730,11 +1791,11 @@ primRunIO m realWorld = error "panic: Hugs entered the real world" protect :: () -> () protect comp - = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld)) + = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) trace :: String -> a -> a trace s x - = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x unsafeInterleaveST :: ST s a -> ST s a unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) @@ -1744,7 +1805,7 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Addr, ForeignObj, Prim*Array ---------------------------------------------- +-- Word, Addr, ForeignObj, Prim*Array ---------------------------------------- ------------------------------------------------------------------------------ data Addr @@ -1762,9 +1823,22 @@ instance Ord Addr where (>) = primGtAddr -data ForeignObj -makeForeignObj :: Addr -> IO ForeignObj -makeForeignObj = primMakeForeignObj +data Word + +instance Eq Word where + (==) = primEqWord + (/=) = primNeWord + +instance Ord Word where + (<) = primLtWord + (<=) = primLeWord + (>=) = primGeWord + (>) = primGtWord + + +--data ForeignObj +--makeForeignObj :: Addr -> IO ForeignObj +--makeForeignObj = primMakeForeignObj data PrimArray a -- immutable arrays with Int indices @@ -1775,6 +1849,7 @@ data PrimMutableArray s a -- mutable arrays with Int indices data PrimMutableByteArray s + ------------------------------------------------------------------------------ -- hooks to call libHS_cbits ------------------------------------------------- ------------------------------------------------------------------------------ @@ -1971,7 +2046,7 @@ formatRealFloat fmt decs x = s doFmt fmt (is, e) = let ds = map intToDigit is in case fmt of - FFGeneric -> + FFGeneric -> doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) (is, e) FFExponent -> @@ -2060,9 +2135,16 @@ floatToDigits base x = (f*2, b^(-e)*2, 1, 1) k = let k0 = - - 0 - + if b == 2 && base == 10 then + -- logBase 10 2 is slightly bigger than 3/10 so + -- the following will err on the low side. Ignoring + -- the fraction will make it err even more. + -- Haskell promises that p-1 <= logBase b f < p. + (p - 1 + e0) * 3 `div` 10 + else + ceiling ((log (fromInteger (f+1)) + + fromInt e * log (fromInteger b)) / + log (fromInteger base)) fixup n = if n >= 0 then if r + mUp <= expt base n * s then n else fixup (n+1) @@ -2088,6 +2170,23 @@ floatToDigits base x = in gen [] (r * bk) s (mUp * bk) (mDn * bk) in (map toInt (reverse rds), k) +{- -- Exponentiation with(out) a cache for the most common numbers. expt :: Integer -> Int -> Integer expt base n = base^n +-} + + +-- Exponentiation with a cache for the most common numbers. +minExpt = 0::Int +maxExpt = 1100::Int +expt :: Integer -> Int -> Integer +expt base n = + if base == 2 && n >= minExpt && n <= maxExpt then + expts !! (n-minExpt) + else + base^n + +expts :: [Integer] +expts = [2^n | n <- [minExpt .. maxExpt]] + diff --git a/ghc/interpreter/lib/System.hs b/ghc/interpreter/lib/System.hs new file mode 100644 index 0000000..07494a8 --- /dev/null +++ b/ghc/interpreter/lib/System.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- Standard Library: System operations +-- +-- Warning: the implementation of these functions in Hugs 98 is very weak. +-- The functions themselves are best suited to uses in compiled programs, +-- and not to use in an interpreter-based environment like Hugs. +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module System ( + ExitCode(..), exitWith, exitFailure, + getArgs, getProgName, getEnv, + system + ) where + +data ExitCode = ExitSuccess | ExitFailure Int + deriving (Eq, Ord, Read, Show) + +getArgs :: IO [String] +getArgs = primGetRawArgs >>= \rawargs -> + return (drop 1 (dropWhile (/= "--") rawargs)) + +getProgName :: IO String +getProgName = primGetRawArgs >>= \rawargs -> + return (head rawargs) + +getEnv :: String -> IO String +getEnv = primGetEnv + +system :: String -> IO ExitCode +system s = error "System.system unimplemented" + +exitWith :: ExitCode -> IO a +exitWith c = error "System.exitWith unimplemented" + +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +toExitCode :: Int -> ExitCode +toExitCode 0 = ExitSuccess +toExitCode n = ExitFailure n + +fromExitCode :: ExitCode -> Int +fromExitCode ExitSuccess = 0 +fromExitCode (ExitFailure n) = n + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index ce2bb73..297d9fe 100644 --- a/ghc/interpreter/lift.c +++ b/ghc/interpreter/lift.c @@ -10,8 +10,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: lift.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:47 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:06:54 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -25,12 +25,14 @@ * Local function prototypes: * ------------------------------------------------------------------------*/ -static List liftedBinds = NIL; +static List liftedBinds = NIL; +static Bool makeInlineable = FALSE; +static Int inlineCounter = 0; static StgExpr abstractExpr ( List vars, StgExpr e ); static inline Bool isTopLevel( StgVar v ); static List filterFreeVars( List vs ); -static List liftLetBinds ( List binds ); +static List liftLetBinds ( List binds, Bool topLevel ); static void liftAlt ( StgCaseAlt alt ); static void liftPrimAlt ( StgPrimAlt alt ); static void liftExpr ( StgExpr e ); @@ -47,6 +49,7 @@ static StgExpr abstractExpr( List vars, StgExpr e ) for(; nonNull(vars); vars=tl(vars)) { StgVar var = hd(vars); StgVar arg = mkStgVar(NIL,NIL); + stgVarRep(arg) = stgVarRep(var); args = cons(arg,args); sub = cons(pair(var,arg),sub); } @@ -94,7 +97,7 @@ static List filterFreeVars( List vs ) } } -static List liftLetBinds( List binds ) +static List liftLetBinds( List binds, Bool topLevel ) { List bs = NIL; for(; nonNull(binds); binds=tl(binds)) { @@ -103,6 +106,15 @@ static List liftLetBinds( List binds ) List fvs = filterFreeVars(stgVarInfo(bind)); /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */ + /* if starting on a new top-level inlineable bind, ensure that + the lifted-out binds get marked inlineable too + */ + if (topLevel) { + Name n = nameFromStgVar(bind); + makeInlineable = FALSE; + if (nonNull(n) && name(n).inlineMe==TRUE) makeInlineable = TRUE; + } + switch (whatIs(rhs)) { case STGCON: case STGAPP: @@ -111,7 +123,7 @@ static List liftLetBinds( List binds ) if (isNull(fvs)) { StgVar v = mkStgVar(rhs,NONE); stgVarBody(bind) = mkStgLet(singleton(v),v); - /* ppStg(v); */ + /* ppStg(v); */ /* check inlinable */ liftedBinds = cons(bind,liftedBinds); break; } @@ -125,9 +137,19 @@ static List liftLetBinds( List binds ) liftExpr(rhs); if (nonNull(fvs)) { StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE); - /* ppStg(v); */ liftedBinds = cons(v,liftedBinds); - stgVarBody(bind) = makeStgApp(v, fvs); + if (makeInlineable) { + Name n; + char s[16]; + sprintf(s,"lam%d",inlineCounter++); + n = newName(findText(s),NIL); + name(n).stgVar = v; + name(n).simplified = TRUE; /* optimiser is upstream of lifter */ + if (makeInlineable) name(n).inlineMe = TRUE; + stgVarBody(bind) = makeStgApp(n, fvs); + } else { + stgVarBody(bind) = makeStgApp(v, fvs); + } } #if LIFT_CONSTANTS #error lift constants @@ -151,7 +173,9 @@ static List liftLetBinds( List binds ) static void liftAlt( StgCaseAlt alt ) { - liftExpr(stgCaseAltBody(alt)); + if (isDefaultAlt(alt)) + liftExpr(stgDefaultBody(alt)); else + liftExpr(stgCaseAltBody(alt)); } static void liftPrimAlt( StgPrimAlt alt ) @@ -163,7 +187,7 @@ static void liftExpr( StgExpr e ) { switch (whatIs(e)) { case LETREC: - stgLetBinds(e) = liftLetBinds(stgLetBinds(e)); + stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE); liftExpr(stgLetBody(e)); break; case LAMBDA: @@ -189,17 +213,27 @@ static void liftExpr( StgExpr e ) } } +/* Lift a list of top-level binds. */ List liftBinds( List binds ) { List bs; + for(bs=binds; nonNull(bs); bs=tl(bs)) { StgVar bind = hd(bs); freeVarsBind(NIL,bind); stgVarInfo(bind) = NONE; /* mark as top level */ } + liftedBinds = NIL; - binds = liftLetBinds(binds); + binds = liftLetBinds(binds,TRUE); binds = revOnto(liftedBinds,binds); + + for (bs=binds; nonNull(bs); bs=tl(bs)) { + Name n = nameFromStgVar(hd(bs)); + if (nonNull(n)) + name(n).stgSize = stgSize(stgVarBody(name(n).stgVar)); + } + liftedBinds = NIL; return binds; } diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index c3595c0..6fc348c 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: link.c,v $ - * $Revision: 1.6 $ - * $Date: 1999/03/09 14:51:08 $ + * $Revision: 1.7 $ + * $Date: 1999/04/27 10:06:54 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -20,237 +20,201 @@ #include "link.h" -////Module modulePreludeHugs; - -Type typeArrow =BOGUS(1); /* Function spaces */ - -Type typeChar =BOGUS(2); -Type typeInt =BOGUS(3); -#ifdef PROVIDE_INT64 -Type typeInt64 =BOGUS(4); -#endif -#ifdef PROVIDE_INTEGER -Type typeInteger =BOGUS(5); -#endif -#ifdef PROVIDE_WORD -Type typeWord =BOGUS(6); -#endif -#ifdef PROVIDE_ADDR -Type typeAddr =BOGUS(7); -#endif -#ifdef PROVIDE_ARRAY -Type typePrimArray =BOGUS(8); -Type typePrimByteArray =BOGUS(9); -Type typeRef =BOGUS(10); -Type typePrimMutableArray =BOGUS(11); -Type typePrimMutableByteArray =BOGUS(12); -#endif -Type typeFloat =BOGUS(13); -Type typeDouble =BOGUS(14); +Type typeArrow; /* Function spaces */ + +Type typeChar; +Type typeInt; +Type typeInteger; +Type typeWord; +Type typeAddr; +Type typePrimArray; +Type typePrimByteArray; +Type typeRef; +Type typePrimMutableArray; +Type typePrimMutableByteArray; +Type typeFloat; +Type typeDouble; #ifdef PROVIDE_STABLE -Type typeStable =BOGUS(15); +Type typeStable; #endif #ifdef PROVIDE_WEAK -Type typeWeak =BOGUS(16); +Type typeWeak; #endif #ifdef PROVIDE_FOREIGN -Type typeForeign =BOGUS(17); +Type typeForeign; #endif #ifdef PROVIDE_CONCURRENT -Type typeThreadId =BOGUS(18); -Type typeMVar =BOGUS(19); -#endif - -Type typeList =BOGUS(20); -Type typeUnit =BOGUS(21); -Type typeString =BOGUS(22); -Type typeBool =BOGUS(23); -Type typeST =BOGUS(24); -Type typeIO =BOGUS(25); -Type typeException =BOGUS(26); - -Class classEq =BOGUS(27); /* `standard' classes */ -Class classOrd =BOGUS(28); -Class classShow =BOGUS(29); -Class classRead =BOGUS(30); -Class classIx =BOGUS(31); -Class classEnum =BOGUS(32); -Class classBounded =BOGUS(33); -#if EVAL_INSTANCES -Class classEval =BOGUS(34); -#endif - -Class classReal =BOGUS(35); /* `numeric' classes */ -Class classIntegral =BOGUS(36); -Class classRealFrac =BOGUS(37); -Class classRealFloat =BOGUS(38); -Class classFractional =BOGUS(39); -Class classFloating =BOGUS(40); -Class classNum =BOGUS(41); - -Class classMonad =BOGUS(42); /* Monads and monads with a zero */ -/*Class classMonad0 =BOGUS();*/ - -List stdDefaults =BOGUS(43); /* standard default values */ - -Name nameTrue =BOGUS(44), - nameFalse =BOGUS(45); /* primitive boolean constructors */ -Name nameNil =BOGUS(46), - nameCons =BOGUS(47); /* primitive list constructors */ -Name nameUnit =BOGUS(48); /* primitive Unit type constructor */ - -Name nameEq =BOGUS(49); -Name nameFromInt =BOGUS(50), - nameFromDouble =BOGUS(51); /* coercion of numerics */ -Name nameFromInteger =BOGUS(52); -Name nameReturn =BOGUS(53), - nameBind =BOGUS(54); /* for translating monad comps */ -Name nameZero =BOGUS(55); /* for monads with a zero */ -#if EVAL_INSTANCES -Name nameStrict =BOGUS(56); /* Members of class Eval */ -Name nameSeq =BOGUS(57); -#endif - -Name nameId =BOGUS(58); -Name nameRunIO =BOGUS(59); -Name namePrint =BOGUS(60); - -Name nameOtherwise =BOGUS(61); -Name nameUndefined =BOGUS(62); /* generic undefined value */ +Type typeThreadId; +Type typeMVar; +#endif + +Type typeList; +Type typeUnit; +Type typeString; +Type typeBool; +Type typeST; +Type typeIO; +Type typeException; + +Class classEq; /* `standard' classes */ +Class classOrd; +Class classShow; +Class classRead; +Class classIx; +Class classEnum; +Class classBounded; + +Class classReal; /* `numeric' classes */ +Class classIntegral; +Class classRealFrac; +Class classRealFloat; +Class classFractional; +Class classFloating; +Class classNum; +Class classMonad; /* Monads and monads with a zero */ + +List stdDefaults; /* standard default values */ + +Name nameTrue; +Name nameFalse; /* primitive boolean constructors */ +Name nameNil; +Name nameCons; /* primitive list constructors */ +Name nameUnit; /* primitive Unit type constructor */ + +Name nameEq; +Name nameFromInt; +Name nameFromDouble; /* coercion of numerics */ +Name nameFromInteger; +Name nameReturn; +Name nameBind; /* for translating monad comps */ +Name nameZero; /* for monads with a zero */ + +Name nameId; +Name nameRunIO; +Name namePrint; + +Name nameOtherwise; +Name nameUndefined; /* generic undefined value */ #if NPLUSK -Name namePmSub =BOGUS(63); +Name namePmSub; #endif -Name namePMFail =BOGUS(64); -Name namePMFailBUG = BOGUS(666); -Name nameEqChar =BOGUS(65); -Name nameEqInt =BOGUS(66); +Name namePMFail; +Name nameEqChar; +Name nameEqInt; #if !OVERLOADED_CONSTANTS -Name nameEqInteger =BOGUS(67); -#endif -Name nameEqDouble =BOGUS(68); -Name namePmInt =BOGUS(69); -Name namePmInteger =BOGUS(70); -Name namePmDouble =BOGUS(71); -Name namePmLe =BOGUS(72); -Name namePmSubtract =BOGUS(73); -Name namePmFromInteger =BOGUS(74); -Name nameMkIO =BOGUS(75); -Name nameUnpackString =BOGUS(76); -Name nameError =BOGUS(77); -Name nameInd =BOGUS(78); - -Name nameAnd =BOGUS(80); -Name nameConCmp =BOGUS(82); -Name nameCompAux =BOGUS(83); -Name nameEnFrTh =BOGUS(84); -Name nameEnFrTo =BOGUS(85); -Name nameEnFrom =BOGUS(86); -Name nameEnFrEn =BOGUS(87); -Name nameEnToEn =BOGUS(88); -Name nameEnInRng =BOGUS(89); -Name nameEnIndex =BOGUS(90); -Name nameEnRange =BOGUS(91); -Name nameRangeSize =BOGUS(92); -Name nameComp =BOGUS(93); -Name nameShowField =BOGUS(94); -Name nameApp =BOGUS(95); -Name nameShowParen =BOGUS(96); -Name nameReadParen =BOGUS(97); -Name nameLex =BOGUS(98); -Name nameReadField =BOGUS(99); -Name nameFlip =BOGUS(100); - -Name namePrimSeq =BOGUS(1000); -Name namePrimCatch =BOGUS(1001); -Name namePrimRaise =BOGUS(1002); - -Name nameFromTo =BOGUS(101); -Name nameFromThen =BOGUS(102); -Name nameFrom =BOGUS(103); -Name nameFromThenTo =BOGUS(104); -Name nameNegate =BOGUS(105); +Name nameEqInteger; +#endif +Name nameEqDouble; +Name namePmInt; +Name namePmInteger; +Name namePmDouble; +Name namePmLe; +Name namePmSubtract; +Name namePmFromInteger; +Name nameMkIO; +Name nameUnpackString; +Name nameError; +Name nameInd; + +Name nameAnd; +Name nameConCmp; +Name nameCompAux; +Name nameEnFrTh; +Name nameEnFrTo; +Name nameEnFrom; +Name nameEnFrEn; +Name nameEnToEn; +Name nameEnInRng; +Name nameEnIndex; +Name nameEnRange; +Name nameRangeSize; +Name nameComp; +Name nameShowField; +Name nameApp; +Name nameShowParen; +Name nameReadParen; +Name nameLex; +Name nameReadField; +Name nameFlip; + +Name namePrimSeq; +Name namePrimCatch; +Name namePrimRaise; + +Name nameFromTo; +Name nameFromThen; +Name nameFrom; +Name nameFromThenTo; +Name nameNegate; /* these names are required before we've had a chance to do the right thing */ -Name nameSel =BOGUS(106); -Name nameUnsafeUnpackCString =BOGUS(107); +Name nameSel; +Name nameUnsafeUnpackCString; /* constructors used during translation and codegen */ -Name nameMkC =BOGUS(108); /* Char# -> Char */ -Name nameMkI =BOGUS(109); /* Int# -> Int */ -#ifdef PROVIDE_INT64 -Name nameMkInt64 =BOGUS(110); /* Int64# -> Int64 */ -#endif -#ifdef PROVIDE_INTEGER -Name nameMkInteger =BOGUS(111); /* Integer# -> Integer */ -#endif -#ifdef PROVIDE_WORD -Name nameMkW =BOGUS(112); /* Word# -> Word */ -#endif -#ifdef PROVIDE_ADDR -Name nameMkA =BOGUS(113); /* Addr# -> Addr */ -#endif -Name nameMkF =BOGUS(114); /* Float# -> Float */ -Name nameMkD =BOGUS(115); /* Double# -> Double */ -#ifdef PROVIDE_ARRAY -Name nameMkPrimArray =BOGUS(116); -Name nameMkPrimByteArray =BOGUS(117); -Name nameMkRef =BOGUS(118); -Name nameMkPrimMutableArray =BOGUS(119); -Name nameMkPrimMutableByteArray =BOGUS(120); -#endif +Name nameMkC; /* Char# -> Char */ +Name nameMkI; /* Int# -> Int */ +Name nameMkInteger; /* Integer# -> Integer */ +Name nameMkW; /* Word# -> Word */ +Name nameMkA; /* Addr# -> Addr */ +Name nameMkF; /* Float# -> Float */ +Name nameMkD; /* Double# -> Double */ +Name nameMkPrimArray; +Name nameMkPrimByteArray; +Name nameMkRef; +Name nameMkPrimMutableArray; +Name nameMkPrimMutableByteArray; #ifdef PROVIDE_STABLE -Name nameMkStable =BOGUS(121); /* StablePtr# a -> StablePtr a */ +Name nameMkStable; /* StablePtr# a -> StablePtr a */ #endif #ifdef PROVIDE_WEAK -Name nameMkWeak =BOGUS(122); /* Weak# a -> Weak a */ +Name nameMkWeak; /* Weak# a -> Weak a */ #endif #ifdef PROVIDE_FOREIGN -Name nameMkForeign =BOGUS(123); /* ForeignObj# -> ForeignObj */ +Name nameMkForeign; /* ForeignObj# -> ForeignObj */ #endif #ifdef PROVIDE_CONCURRENT -Name nameMkThreadId =BOGUS(124); /* ThreadId# -> ThreadId */ -Name nameMkMVar =BOGUS(125); /* MVar# -> MVar */ +Name nameMkThreadId; /* ThreadId# -> ThreadId */ +Name nameMkMVar; /* MVar# -> MVar */ #endif -Name nameMinBnd =BOGUS(400); -Name nameMaxBnd =BOGUS(401); -Name nameCompare =BOGUS(402); -Name nameShowsPrec =BOGUS(403); -Name nameIndex =BOGUS(404); -Name nameReadsPrec =BOGUS(405); -Name nameRange =BOGUS(406); -Name nameEQ =BOGUS(407); -Name nameInRange =BOGUS(408); -Name nameGt =BOGUS(409); -Name nameLe =BOGUS(410); -Name namePlus =BOGUS(411); -Name nameMult =BOGUS(412); -Name nameMFail =BOGUS(413); -Type typeOrdering =BOGUS(414); -Module modulePrelude =BOGUS(415); -Name nameMap = BOGUS(416); -Name nameMinus = BOGUS(417); - -#define QQ(lval) assert(lval != 0); assert(lval <= -900000); lval +Name nameMinBnd; +Name nameMaxBnd; +Name nameCompare; +Name nameShowsPrec; +Name nameIndex; +Name nameReadsPrec; +Name nameRange; +Name nameEQ; +Name nameInRange; +Name nameGt; +Name nameLe; +Name namePlus; +Name nameMult; +Name nameMFail; +Type typeOrdering; +Module modulePrelude; +Name nameMap; +Name nameMinus; + /* -------------------------------------------------------------------------- * Frequently used type skeletons: * ------------------------------------------------------------------------*/ -/* ToDo: move these to link.c and call them 'typeXXXX' */ - Type arrow=BOGUS(500); /* mkOffset(0) -> mkOffset(1) */ - Type boundPair=BOGUS(500);; /* (mkOffset(0),mkOffset(0)) */ - Type listof=BOGUS(500);; /* [ mkOffset(0) ] */ - Type typeVarToVar=BOGUS(500);; /* mkOffset(0) -> mkOffset(0) */ +Type arrow; /* mkOffset(0) -> mkOffset(1) */ +Type boundPair; /* (mkOffset(0),mkOffset(0)) */ +Type listof; /* [ mkOffset(0) ] */ +Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */ - Cell predNum=BOGUS(500);; /* Num (mkOffset(0)) */ - Cell predFractional=BOGUS(500);; /* Fractional (mkOffset(0)) */ - Cell predIntegral=BOGUS(500);; /* Integral (mkOffset(0)) */ - Kind starToStar=BOGUS(500);; /* Type -> Type */ - Cell predMonad=BOGUS(500);; /* Monad (mkOffset(0)) */ +Cell predNum; /* Num (mkOffset(0)) */ +Cell predFractional; /* Fractional (mkOffset(0)) */ +Cell predIntegral; /* Integral (mkOffset(0)) */ +Kind starToStar; /* Type -> Type */ +Cell predMonad; /* Monad (mkOffset(0)) */ /* -------------------------------------------------------------------------- * @@ -314,116 +278,88 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ initialised = TRUE; setCurrModule(modulePrelude); - QQ(typeChar ) = linkTycon("Char"); - QQ(typeInt ) = linkTycon("Int"); -#ifdef PROVIDE_INT64 - QQ(typeInt64 ) = linkTycon("Int64"); -#endif -#ifdef PROVIDE_INTEGER - QQ(typeInteger ) = linkTycon("Integer"); -#endif -#ifdef PROVIDE_WORD - QQ(typeWord ) = linkTycon("Word"); -#endif -#ifdef PROVIDE_ADDR - QQ(typeAddr ) = linkTycon("Addr"); -#endif -#ifdef PROVIDE_ARRAY - QQ(typePrimArray ) = linkTycon("PrimArray"); - QQ(typePrimByteArray) = linkTycon("PrimByteArray"); - QQ(typeRef ) = linkTycon("Ref"); - QQ(typePrimMutableArray) = linkTycon("PrimMutableArray"); - QQ(typePrimMutableByteArray) = linkTycon("PrimMutableByteArray"); -#endif - QQ(typeFloat ) = linkTycon("Float"); - QQ(typeDouble ) = linkTycon("Double"); + typeChar = linkTycon("Char"); + typeInt = linkTycon("Int"); + typeInteger = linkTycon("Integer"); + typeWord = linkTycon("Word"); + typeAddr = linkTycon("Addr"); + typePrimArray = linkTycon("PrimArray"); + typePrimByteArray = linkTycon("PrimByteArray"); + typeRef = linkTycon("Ref"); + typePrimMutableArray = linkTycon("PrimMutableArray"); + typePrimMutableByteArray = linkTycon("PrimMutableByteArray"); + typeFloat = linkTycon("Float"); + typeDouble = linkTycon("Double"); #ifdef PROVIDE_STABLE - QQ(typeStable ) = linkTycon("StablePtr"); + typeStable = linkTycon("StablePtr"); #endif #ifdef PROVIDE_WEAK - QQ(typeWeak ) = linkTycon("Weak"); + typeWeak = linkTycon("Weak"); #endif #ifdef PROVIDE_FOREIGN - QQ(typeForeign ) = linkTycon("ForeignObj"); + typeForeign = linkTycon("ForeignObj"); #endif #ifdef PROVIDE_CONCURRENT - QQ(typeThreadId ) = linkTycon("ThreadId"); - QQ(typeMVar ) = linkTycon("MVar"); -#endif - - QQ(typeBool ) = linkTycon("Bool"); - QQ(typeST ) = linkTycon("ST"); - QQ(typeIO ) = linkTycon("IO"); - QQ(typeException ) = linkTycon("Exception"); - //qqfail QQ(typeList ) = linkTycon("[]"); - //qqfail QQ(typeUnit ) = linkTycon("()"); - QQ(typeString ) = linkTycon("String"); - QQ(typeOrdering ) = linkTycon("Ordering"); - - QQ(classEq ) = linkClass("Eq"); - QQ(classOrd ) = linkClass("Ord"); - QQ(classIx ) = linkClass("Ix"); - QQ(classEnum ) = linkClass("Enum"); - QQ(classShow ) = linkClass("Show"); - QQ(classRead ) = linkClass("Read"); - QQ(classBounded ) = linkClass("Bounded"); -#if EVAL_INSTANCES - classEval = linkClass("Eval"); -#endif - QQ(classReal ) = linkClass("Real"); - QQ(classIntegral ) = linkClass("Integral"); - QQ(classRealFrac ) = linkClass("RealFrac"); - QQ(classRealFloat) = linkClass("RealFloat"); - QQ(classFractional) = linkClass("Fractional"); - QQ(classFloating ) = linkClass("Floating"); - QQ(classNum ) = linkClass("Num"); - QQ(classMonad ) = linkClass("Monad"); + typeThreadId = linkTycon("ThreadId"); + typeMVar = linkTycon("MVar"); +#endif + + typeBool = linkTycon("Bool"); + typeST = linkTycon("ST"); + typeIO = linkTycon("IO"); + typeException = linkTycon("Exception"); + typeString = linkTycon("String"); + typeOrdering = linkTycon("Ordering"); + + classEq = linkClass("Eq"); + classOrd = linkClass("Ord"); + classIx = linkClass("Ix"); + classEnum = linkClass("Enum"); + classShow = linkClass("Show"); + classRead = linkClass("Read"); + classBounded = linkClass("Bounded"); + classReal = linkClass("Real"); + classIntegral = linkClass("Integral"); + classRealFrac = linkClass("RealFrac"); + classRealFloat = linkClass("RealFloat"); + classFractional = linkClass("Fractional"); + classFloating = linkClass("Floating"); + classNum = linkClass("Num"); + classMonad = linkClass("Monad"); stdDefaults = NIL; stdDefaults = cons(typeDouble,stdDefaults); #if DEFAULT_BIGNUM - stdDefaults = cons(typeBignum,stdDefaults); + stdDefaults = cons(typeInteger,stdDefaults); #else stdDefaults = cons(typeInt,stdDefaults); #endif mkTypes(); - QQ(nameMkC ) = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); - QQ(nameMkI ) = addPrimCfunREP(findText("I#"),1,0,INT_REP); -#ifdef PROVIDE_INT64 - QQ(nameMkInt64 ) = addPrimCfunREP(findText("Int64#"),1,0,INT64_REP); -#endif -#ifdef PROVIDE_WORD - QQ(nameMkW ) = addPrimCfunREP(findText("W#"),1,0,WORD_REP); -#endif -#ifdef PROVIDE_ADDR - QQ(nameMkA ) = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); -#endif - QQ(nameMkF ) = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); - QQ(nameMkD ) = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); + nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); + nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP); + nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP); + nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); + nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); + nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); #ifdef PROVIDE_STABLE - QQ(nameMkStable ) = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); -#endif - -#ifdef PROVIDE_INTEGER - QQ(nameMkInteger ) = addPrimCfunREP(findText("Integer#"),1,0,0); + nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); #endif + nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); #ifdef PROVIDE_FOREIGN - QQ(nameMkForeign ) = addPrimCfunREP(findText("Foreign#"),1,0,0); + nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); #endif #ifdef PROVIDE_WEAK - QQ(nameMkWeak ) = addPrimCfunREP(findText("Weak#"),1,0,0); -#endif -#ifdef PROVIDE_ARRAY - QQ(nameMkPrimArray ) = addPrimCfunREP(findText("PrimArray#"),1,0,0); - QQ(nameMkPrimByteArray ) = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); - QQ(nameMkRef ) = addPrimCfunREP(findText("Ref#"),1,0,0); - QQ(nameMkPrimMutableArray ) = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); - QQ(nameMkPrimMutableByteArray) = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0); + nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0); #endif + nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0); + nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); + nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0); + nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); + nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0); #ifdef PROVIDE_CONCURRENT - QQ(nameMkThreadId) = addPrimCfun(findTextREP("ThreadId#"),1,0,0); - QQ(nameMkMVar ) = addPrimCfun(findTextREP("MVar#"),1,0,0); + nameMkThreadId = addPrimCfun(findTextREP("ThreadId#"),1,0,0); + nameMkMVar = addPrimCfun(findTextREP("MVar#"),1,0,0); #endif /* The following primitives are referred to in derived instances and * hence require types; the following types are a little more general @@ -454,44 +390,24 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ = primType(MONAD_Id, "aH", "a"); name(namePrimRaise).type = primType(MONAD_Id, "E", "a"); -#if EVAL_INSTANCES - addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */ -#endif for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */ -#if EVAL_INSTANCES - addEvalInst(0,mkTuple(i),i,NIL); -#endif -#if DERIVE_EQ addTupInst(classEq,i); -#endif -#if DERIVE_ORD addTupInst(classOrd,i); -#endif -#if DERIVE_IX addTupInst(classIx,i); -#endif -#if DERIVE_SHOW addTupInst(classShow,i); -#endif -#if DERIVE_READ addTupInst(classRead,i); -#endif -#if DERIVE_BOUNDED addTupInst(classBounded,i); -#endif } } } static Void mkTypes ( void ) { - //qqfail QQ(arrow ) = fn(aVar,mkOffset(1)); - //qqfail QQ(listof ) = ap(typeList,aVar); - QQ(predNum ) = ap(classNum,aVar); - QQ(predFractional) = ap(classFractional,aVar); - QQ(predIntegral ) = ap(classIntegral,aVar); - QQ(predMonad ) = ap(classMonad,aVar); + predNum = ap(classNum,aVar); + predFractional = ap(classFractional,aVar); + predIntegral = ap(classIntegral,aVar); + predMonad = ap(classMonad,aVar); } Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ @@ -499,41 +415,35 @@ Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ if (!initialised) { Int i; initialised = TRUE; - ////setCurrModule(modulePreludeHugs); + setCurrModule(modulePrelude); + /* constructors */ - QQ(nameFalse ) = linkName("False"); - QQ(nameTrue ) = linkName("True"); - //qqfail QQ(nameNil ) = linkName("[]"); - //qqfail QQ(nameCons ) = linkName(":"); - //qqfail QQ(nameUnit ) = linkName("()"); + nameFalse = linkName("False"); + nameTrue = linkName("True"); + /* members */ - QQ(nameEq ) = linkName("=="); - QQ(nameFromInt ) = linkName("fromInt"); - QQ(nameFromInteger) = linkName("fromInteger"); - QQ(nameFromDouble) = linkName("fromDouble"); -#if EVAL_INSTANCES - nameStrict = linkName("strict"); - nameSeq = linkName("seq"); -#endif - QQ(nameReturn ) = linkName("return"); - QQ(nameBind ) = linkName(">>="); - - QQ(nameLe ) = linkName("<="); - QQ(nameGt ) = linkName(">"); - QQ(nameShowsPrec ) = linkName("showsPrec"); - QQ(nameReadsPrec ) = linkName("readsPrec"); - QQ(nameEQ ) = linkName("EQ"); - QQ(nameCompare ) = linkName("compare"); - QQ(nameMinBnd ) = linkName("minBound"); - QQ(nameMaxBnd ) = linkName("maxBound"); - QQ(nameRange ) = linkName("range"); - QQ(nameIndex ) = linkName("index"); - QQ(namePlus ) = linkName("+"); - QQ(nameMult ) = linkName("*"); - QQ(nameRangeSize ) = linkName("rangeSize"); - QQ(nameInRange ) = linkName("inRange"); - QQ(nameMinus ) = linkName("-"); + nameEq = linkName("=="); + nameFromInt = linkName("fromInt"); + nameFromInteger = linkName("fromInteger"); + nameFromDouble = linkName("fromDouble"); + nameReturn = linkName("return"); + nameBind = linkName(">>="); + nameLe = linkName("<="); + nameGt = linkName(">"); + nameShowsPrec = linkName("showsPrec"); + nameReadsPrec = linkName("readsPrec"); + nameEQ = linkName("EQ"); + nameCompare = linkName("compare"); + nameMinBnd = linkName("minBound"); + nameMaxBnd = linkName("maxBound"); + nameRange = linkName("range"); + nameIndex = linkName("index"); + namePlus = linkName("+"); + nameMult = linkName("*"); + nameRangeSize = linkName("rangeSize"); + nameInRange = linkName("inRange"); + nameMinus = linkName("-"); /* These come before calls to implementPrim */ for(i=0; i=CStackBase) markWithoutMove(*ptr--) -#define GuessDirection if (ptr>CStackBase) StackGrowsUp; else StackGrowsDown +#define Blargh markWithoutMove(*ptr); +#if 0 + markWithoutMove((*ptr)/sizeof(Cell)); \ + markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \ + markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell)) +#endif + +#define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; } +#define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; } +#define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown #if STACK_DIRECTION > 0 StackGrowsUp; diff --git a/ghc/interpreter/nHandle.c b/ghc/interpreter/nHandle.c index 1e601b9..063bc79 100644 --- a/ghc/interpreter/nHandle.c +++ b/ghc/interpreter/nHandle.c @@ -7,6 +7,7 @@ #include #include #include +#include int nh_stdin ( void ) { @@ -20,6 +21,12 @@ int nh_stdout ( void ) return (int)stdout; } +int nh_stderr ( void ) +{ + errno = 0; + return (int)stderr; +} + int nh_open ( char* fname, int wr ) { FILE* f; @@ -35,6 +42,12 @@ void nh_close ( FILE* f ) fclose ( f ); } +void nh_flush ( FILE* f ) +{ + errno = 0; + fflush ( f ); +} + void nh_write ( FILE* f, int c ) { errno = 0; @@ -65,7 +78,30 @@ void nh_free ( int n ) free ( (char*)n ); } -void nh_assign ( int p, int offset, int ch ) +void nh_store ( int p, int ch ) +{ + *(char*)p = (char)ch; +} + +int nh_load ( int p ) +{ + return (int)(*(char*)p); +} + +int nh_getenv ( int p ) +{ + return (int)getenv ( (const char *)p ); +} + +extern int prog_argc; +extern char** prog_argv; + +int nh_argc ( void ) +{ + return prog_argc; +} + +int nh_argvb ( int argno, int offset ) { - ((char*)p)[offset] = (char)ch; + return (int)(prog_argv[argno][offset]); } diff --git a/ghc/interpreter/optimise.c b/ghc/interpreter/optimise.c index a891389..313116c 100644 --- a/ghc/interpreter/optimise.c +++ b/ghc/interpreter/optimise.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: optimise.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/09 14:51:09 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:06:57 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -16,221 +16,2356 @@ #include "backend.h" #include "connect.h" #include "errors.h" +#include "link.h" +#include "Assembler.h" + +/* #define DEBUG_OPTIMISE */ /* -------------------------------------------------------------------------- * Local functions * ------------------------------------------------------------------------*/ -static StgAtom optimiseAtom Args((StgAtom)); -static StgVar optimiseVar Args((StgVar)); -static StgCaseAlt optimiseAlt Args((StgCaseAlt)); -static StgPrimAlt optimisePrimAlt Args((StgPrimAlt)); -static StgExpr optimiseExpr Args((StgExpr)); +Int nLoopBreakersInlined; +Int nLetvarsInlined; +Int nTopvarsInlined; +Int nCaseOfLet; +Int nCaseOfCase; +Int nCaseOfPrimCase; +Int nCaseOfCon; +Int nCaseOfOuter; +Int nLetBindsDropped; +Int nLetrecGroupsDropped; +Int nLambdasMerged; +Int nCaseDefaultsDropped; +Int nAppsMerged; +Int nLetsFloatedOutOfFn; +Int nLetsFloatedIntoCase; +Int nCasesFloatedOutOfFn; +Int nBetaReductions; + +Int nTotSizeIn; +Int nTotSizeOut; + +Int rDepth; +Bool copyInTopvar; +Bool inDBuilder; + +static void local optimiseTopBind( StgVar v ); + +typedef + enum { + CTX_SCRUT, + CTX_OTHER + } + InlineCtx; + +/* Exactly like whatIs except it avoids a fn call for STG tags */ +#define whatIsStg(xx) ((isPair(xx) ? (isTag(fst(xx)) ? fst(xx) : AP) : whatIs(xx))) + /* -------------------------------------------------------------------------- - * A simple optimiser + * Transformation stats * ------------------------------------------------------------------------*/ -static StgAtom optimiseAtom(StgAtom a) +void initOptStats ( void ) { - switch (whatIs(a)) { - case STGVAR: - return optimiseVar(a); - /* Note that NAMEs have no free vars. */ - default: - return a; - } + nLoopBreakersInlined = 0; + nLetvarsInlined = 0; + nTopvarsInlined = 0; + nCaseOfLet = 0; + nCaseOfCase = 0; + nCaseOfPrimCase = 0; + nCaseOfCon = 0; + nCaseOfOuter = 0; + nLetBindsDropped = 0; + nLetrecGroupsDropped = 0; + nLambdasMerged = 0; + nCaseDefaultsDropped = 0; + nAppsMerged = 0; + nLetsFloatedOutOfFn = 0; + nLetsFloatedIntoCase = 0; + nCasesFloatedOutOfFn = 0; + nBetaReductions = 0; + nTotSizeIn = 0; + nTotSizeOut = 0; +} + +void printOptStats ( FILE* f ) +{ + fflush(stdout); fflush(stderr); fflush(f); + fprintf(f, "\n\n" ); + fprintf(f, "Inlining: topvar %-5d letvar %-5d" + " loopbrkr %-5d betaredn %-5d\n", + nTopvarsInlined, nLetvarsInlined, nLoopBreakersInlined, + nBetaReductions ); + fprintf(f, "Case-of-: let %-5d case %-5d" + " con %-5d case# %-5d\n", + nCaseOfLet, nCaseOfCase, nCaseOfCon, nCaseOfPrimCase ); + fprintf(f, "Dropped: letbind %-5d letgroup %-5d" + " default %-5d\n", + nLetBindsDropped, nLetrecGroupsDropped, nCaseDefaultsDropped ); + fprintf(f, "Merges: lambda %-5d app %-5d\n", + nLambdasMerged, nAppsMerged ); + fprintf(f, "Fn-float: let %-5d case %-5d\n", + nLetsFloatedOutOfFn, nCasesFloatedOutOfFn ); + fprintf(f, "Misc: case-outer %-5d let-into-case %-5d\n", + nCaseOfOuter, nLetsFloatedIntoCase ); + fprintf(f, "total size: in %-5d out %-5d\n", + nTotSizeIn, nTotSizeOut ); + fprintf(f, "\n" ); +} + + +/* -------------------------------------------------------------------------- + * How big is this STG tree (viz (primarily), do I want to inline it?) + * ------------------------------------------------------------------------*/ + +Int stgSize_list ( List es ) +{ + Int n = 0; + for (; nonNull(es); es=tl(es)) n += stgSize(hd(es)); + return n; +} + +Int stgSize ( StgExpr e ) +{ + List xs; + Int n = 1; + + if (isNull(e)) return 0; + + switch(whatIsStg(e)) { + case STGVAR: + break; + case LETREC: + for (xs = stgLetBinds(e); nonNull(xs);xs=tl(xs)) + n += stgSize(stgVarBody(hd(xs))); + n += stgSize(stgLetBody(e)); + break; + case LAMBDA: + n += stgSize(stgLambdaBody(e)); + break; + case CASE: + n += stgSize_list(stgCaseAlts(e)); + n += stgSize(stgCaseScrut(e)); + break; + case PRIMCASE: + n += stgSize_list(stgPrimCaseAlts(e)); + n += stgSize(stgPrimCaseScrut(e)); + break; + case STGAPP: + n += stgSize_list(stgAppArgs(e)); + n += stgSize(stgAppFun(e)); + break; + case STGPRIM: + n += stgSize_list(stgPrimArgs(e)); + n += stgSize(stgPrimOp(e)); + break; + case STGCON: + n += stgSize_list(stgConArgs(e)); + n += stgSize(stgConCon(e)); + break; + case DEEFALT: + n = stgSize(stgDefaultBody(e)); + break; + case CASEALT: + n = stgSize(stgCaseAltBody(e)); + break; + case PRIMALT: + n = stgSize(stgPrimAltBody(e)); + break; + case INTCELL: + case STRCELL: + case PTRCELL: + case CHARCELL: + case FLOATCELL: + case BIGCELL: + case NAME: + case TUPLE: + break; + default: + fprintf(stderr, "sizeStg: unknown stuff %d\n",whatIsStg(e)); + assert(0); + } + return n; +} + + +/* -------------------------------------------------------------------------- + * Stacks of pairs of collectable things. Used to implement associations. + * cloneStg() uses its stack to map old var names to new ones. + * ------------------------------------------------------------------------*/ + +#define M_PAIRS 400 +#define SP_NOT_IN_USE (-123456789) + +typedef + struct { Cell pfst; Cell psnd; } + StgPair; + +static Int spClone; +static StgPair pairClone[M_PAIRS]; + +void markPairs ( void ) +{ + Int i; + if (spClone != SP_NOT_IN_USE) { + for (i = 0; i <= spClone; i++) { + mark(pairClone[i].pfst); + mark(pairClone[i].psnd); + } + } +} + +void pushClone ( Cell a, Cell b ) +{ + spClone++; + if (spClone >= M_PAIRS) internal("pushClone -- M_PAIRS too small"); + pairClone[spClone].pfst = a; + pairClone[spClone].psnd = b; +} + +void dropClone ( void ) +{ + if (spClone < 0) internal("dropClone"); + spClone--; +} + +Cell findClone ( Cell x ) +{ + Int i; + for (i = spClone; i >= 0; i--) + if (pairClone[i].pfst == x) + return pairClone[i].psnd; + return NIL; +} + + +/* -------------------------------------------------------------------------- + * Cloning of STG trees + * ------------------------------------------------------------------------*/ + +/* Clone v to create a new var. Works for both StgVar and StgPrimVar. */ +StgVar cloneStgVar ( StgVar v ) +{ + return ap(STGVAR,triple(stgVarBody(v),stgVarRep(v),NIL)); } -static StgVar optimiseVar(StgVar v) + +/* For each StgVar in origVars, make a new one with cloneStgVar, + and push the (old,new) pair on the clone pair stack. Returns + the list of new vars. +*/ +List cloneStg_addVars ( List origVars ) +{ + List newVars = NIL; + while (nonNull(origVars)) { + StgVar newv = cloneStgVar(hd(origVars)); + pushClone ( hd(origVars), newv ); + newVars = cons(newv,newVars); + origVars = tl(origVars); + } + newVars = rev(newVars); + return newVars; +} + + +void cloneStg_dropVars ( List vs ) +{ + for (; nonNull(vs); vs=tl(vs)) + dropClone(); +} + + +/* Print the clone pair stack. Just for debugging purposes. */ +void ppCloneEnv ( char* s ) +{ + Int i; + fflush(stdout);fflush(stderr); + printf ( "\nenv-%s\n", s ); + for (i = 0; i <= spClone; i++) { + printf ( "\t" ); + ppStgExpr(pairClone[i].pfst); + ppStgExpr(pairClone[i].psnd); + printf ( "\n" ); + }; + printf ( "vne-%s\n", s ); +} + + +StgExpr cloneStg ( StgExpr e ) { - StgRhs rhs = stgVarBody(v); -fprintf(stderr,"optimiseVar ");printStg(stderr,v);fprintf(stderr,"\n"); - /* short circuit: let x = y in ...x... --> let x = y in ...y... */ - if (whatIs(rhs) == STGVAR && rhs != v) { - StgVar v1 = rhs; -fprintf(stderr, "dumpable\n"); + List xs, newvs; + StgVar newv; + StgExpr t; - /* find last variable in chain */ - rhs = stgVarBody(v1); - while (whatIs(rhs) == STGVAR - && rhs != v /* infinite loop */ - ) { - v1 = rhs; - rhs = stgVarBody(rhs); - } + switch(whatIsStg(e)) { + case STGVAR: + newv = findClone(e); + if (nonNull(newv)) return newv; else return e; + case LETREC: + newvs = cloneStg_addVars ( stgLetBinds(e) ); + for (xs = newvs; nonNull(xs);xs=tl(xs)) + stgVarBody(hd(xs)) = cloneStg(stgVarBody(hd(xs))); + t = mkStgLet(newvs,cloneStg(stgLetBody(e))); + cloneStg_dropVars ( stgLetBinds(e) ); + return t; + case LAMBDA: + newvs = cloneStg_addVars ( stgLambdaArgs(e) ); + t = mkStgLambda(newvs, cloneStg(stgLambdaBody(e))); + cloneStg_dropVars ( stgLambdaArgs(e) ); + return t; + case CASE: + xs = dupList(stgCaseAlts(e)); + mapOver(cloneStg,xs); + return mkStgCase(cloneStg(stgCaseScrut(e)),xs); + case PRIMCASE: + xs = dupList(stgPrimCaseAlts(e)); + mapOver(cloneStg,xs); + return mkStgPrimCase(cloneStg(stgPrimCaseScrut(e)),xs); + case STGAPP: + xs = dupList(stgAppArgs(e)); + mapOver(cloneStg,xs); + return mkStgApp(cloneStg(stgAppFun(e)),xs); + case STGPRIM: + xs = dupList(stgPrimArgs(e)); + mapOver(cloneStg,xs); + return mkStgPrim(cloneStg(stgPrimOp(e)),xs); + case STGCON: + xs = dupList(stgConArgs(e)); + mapOver(cloneStg,xs); + return mkStgCon(cloneStg(stgConCon(e)),xs); + case DEEFALT: + newv = cloneStgVar(stgDefaultVar(e)); + pushClone ( stgDefaultVar(e), newv ); + t = mkStgDefault(newv,cloneStg(stgDefaultBody(e))); + dropClone(); + return t; + case CASEALT: + newvs = cloneStg_addVars ( stgCaseAltVars(e) ); + t = mkStgCaseAlt(stgCaseAltCon(e),newvs, + cloneStg(stgCaseAltBody(e))); + cloneStg_dropVars ( stgCaseAltVars(e) ); + return t; + case PRIMALT: + newvs = cloneStg_addVars ( stgPrimAltVars(e) ); + t = mkStgPrimAlt(newvs, cloneStg(stgPrimAltBody(e))); + cloneStg_dropVars ( stgPrimAltVars(e) ); + return t; + case INTCELL: + case STRCELL: + case PTRCELL: + case BIGCELL: + case CHARCELL: + case FLOATCELL: + case NAME: + case TUPLE: + return e; + default: + fprintf(stderr, "cloneStg: unknown stuff %d\n",whatIsStg(e)); + assert(0); + } +} + + +/* Main entry point. Checks against re-entrant use. */ +StgExpr cloneStgTop ( StgExpr e ) +{ + StgExpr res; + if (spClone != SP_NOT_IN_USE) + internal("cloneStgTop"); + spClone = -1; + res = cloneStg ( e ); + assert(spClone == -1); + spClone = SP_NOT_IN_USE; + return res; +} + + + +/* -------------------------------------------------------------------------- + * Sets of StgVars, used by the strongly-connected-components machinery. + * Represented as an array of variables. The vars + * must be in strictly nondecreasing order. Each value may appear + * more than once, so as to make deletion relatively cheap. + + * After a garbage collection happens, the values may have changed, + * so the array will need to be sorted. + + * Using a binary search, membership costs O(log N). Union and + * intersection cost O(N + M). Deletion of a single element costs + * O(N) in the worst case, although if it happens infrequently + * compared to the other ops, it should asymptotically approach O(1). + * ------------------------------------------------------------------------*/ + +#define M_VAR_SETS 4000 +#define MIN_VAR_SET_SIZE 4 +#define M_UNION_TMP 20000 + +typedef + struct { + Int nextfree; + Bool inUse; + Int size; + Int used; + Cell* vs; + } + StgVarSetRec; + +typedef Int StgVarSet; + +StgVarSetRec varSet[M_VAR_SETS]; +Int varSet_nfree; +Int varSet_nextfree; +Cell union_tmp[M_UNION_TMP]; + +#if 0 /* unused since unnecessary */ +/* Shellsort set elems to restore representation invariants */ +static Int shellCells_incs[10] + = { 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524 }; +static void shellCells ( Cell* a, Int lo, Int hi ) +{ + Int i, j, h, N, hp; + Cell v; + + N = hi - lo + 1; if (N < 2) return; + hp = 0; + while (hp < 10 && shellCells_incs[hp] < N) hp++; hp--; + + for (; hp >= 0; hp--) { + h = shellCells_incs[hp]; + i = lo + h; + while (1) { + if (i > hi) break; + v = a[i]; + j = i; + while (a[j-h] > v) { + a[j] = a[j-h]; j = j - h; + if (j <= (lo + h - 1)) break; + } + a[j] = v; i++; + } + } +} +#endif + +/* check that representation invariant still holds */ +static void checkCells ( Cell* a, Int lo, Int hi ) +{ + Int i; + for (i = lo; i < hi; i++) + if (a[i] > a[i+1]) + internal("checkCells"); +} + + +/* Mark set contents for GC */ +void markStgVarSets ( void ) +{ + Int i, j; + for (i = 0; i < M_VAR_SETS; i++) + if (varSet[i].inUse) + for (j = 0; j < varSet[i].used; j++) + mark(varSet[i].vs[j]); +} + + +/* Check representation invariants after GC */ +void checkStgVarSets ( void ) +{ + Int i; + for (i = 0; i < M_VAR_SETS; i++) + if (varSet[i].inUse) + checkCells ( varSet[i].vs, 0, varSet[i].used-1 ); +} + + +/* Allocate a set of a given size */ +StgVarSet allocStgVarSet ( Int size ) +{ + Int i, j; + if (varSet_nextfree == -1) + internal("allocStgVarSet -- run out of var sets"); + i = varSet_nextfree; + varSet_nextfree = varSet[i].nextfree; + varSet[i].inUse = TRUE; + j = MIN_VAR_SET_SIZE; + while (j <= size) j *= 2; + varSet[i].used = 0; + varSet[i].size = j; + varSet[i].vs = malloc(j * sizeof(StgVar) ); + if (!varSet[i].vs) + internal("allocStgVarSet -- can't malloc memory"); + varSet_nfree--; + return i; +} - /* Make all variables in chain point to v1 - * This makes sure we always resolve cycles the same way - * as well as making things faster if we call optimiseVar again + +/* resize (upwards) */ +void resizeStgVarSet ( StgVarSet s, Int size ) +{ + Cell* tmp; + Cell* tmp2; + Int i; + Int j = MIN_VAR_SET_SIZE; + while (j <= size) j *= 2; + if (j < varSet[s].size) return; + tmp = varSet[s].vs; + tmp2 = malloc( j * sizeof(StgVar) ); + if (!tmp2) internal("resizeStgVarSet -- can't malloc memory"); + varSet[s].vs = tmp2; + for (i = 0; i < varSet[s].used; i++) + tmp2[i] = tmp[i]; + free(tmp); +} + + +/* Deallocation ... */ +void freeStgVarSet ( StgVarSet s ) +{ + if (s < 0 || s >= M_VAR_SETS || + !varSet[s].inUse || !varSet[s].vs) + internal("freeStgVarSet"); + free(varSet[s].vs); + varSet[s].inUse = FALSE; + varSet[s].vs = NULL; + varSet[s].nextfree = varSet_nextfree; + varSet_nextfree = s; + varSet_nfree++; +} + + +/* Initialisation */ +void initStgVarSets ( void ) +{ + Int i; + for (i = M_VAR_SETS-1; i >= 0; i--) { + varSet[i].inUse = FALSE; + varSet[i].vs = NULL; + varSet[i].nextfree = i+1; + } + varSet[M_VAR_SETS-1].nextfree = -1; + varSet_nextfree = 0; + varSet_nfree = M_VAR_SETS; +} + + +/* Find a var using binary search */ +Int findInStgVarSet ( StgVarSet s, StgVar v ) +{ + Int lo, mid, hi; + lo = 0; + hi = varSet[s].used-1; + while (1) { + if (lo > hi) return -1; + mid = (hi+lo)/2; + if (varSet[s].vs[mid] == v) return mid; + if (varSet[s].vs[mid] < v) lo = mid+1; else hi = mid-1; + } +} + + +Bool elemStgVarSet ( StgVarSet s, StgVar v ) +{ + return findInStgVarSet(s,v) != -1; +} + +void ppSet ( StgVarSet s ) +{ + Int i; + fprintf(stderr, "{ "); + for (i = 0; i < varSet[s].used; i++) + fprintf(stderr, "%d ", varSet[s].vs[i] ); + fprintf(stderr, "}\n" ); +} + + +void deleteFromStgVarSet ( StgVarSet s, StgVar v ) +{ + Int i, j; + i = findInStgVarSet(s,v); + if (i == -1) return; + j = varSet[s].used-1; + for (; i < j; i++) varSet[s].vs[i] = varSet[s].vs[i+1]; + varSet[s].used--; +} + + +void singletonStgVarSet ( StgVarSet s, StgVar v ) +{ + varSet[s].used = 1; + varSet[s].vs[0] = v; +} + + +void emptyStgVarSet ( StgVarSet s ) +{ + varSet[s].used = 0; +} + + +void copyStgVarSets ( StgVarSet dst, StgVarSet src ) +{ + Int i; + varSet[dst].used = varSet[src].used; + for (i = 0; i < varSet[dst].used; i++) + varSet[dst].vs[i] = varSet[src].vs[i]; +} + + +Int sizeofVarSet ( StgVarSet s ) +{ + return varSet[s].used; +} + + +void unionStgVarSets ( StgVarSet dst, StgVarSet src ) +{ + StgVar v1; + Int pd, ps, i, res_used, tmp_used, dst_used, src_used; + StgVar* dst_vs; + StgVar* src_vs; + StgVar* tmp_vs; + + dst_vs = varSet[dst].vs; + + /* fast track a common (~ 50%) case */ + if (varSet[src].used == 1) { + v1 = varSet[src].vs[0]; + pd = findInStgVarSet(dst,v1); + if (pd != -1) return; + if (varSet[dst].used < varSet[dst].size) { + i = varSet[dst].used; + while (i > 0 && dst_vs[i-1] > v1) { + dst_vs[i] = dst_vs[i-1]; + i--; + } + dst_vs[i] = v1; + varSet[dst].used++; + return; + } + } + + res_used = varSet[dst].used + varSet[src].used; + if (res_used > M_UNION_TMP) + internal("unionStgVarSets -- M_UNION_TMP too small"); + + resizeStgVarSet(dst,res_used); + dst_vs = varSet[dst].vs; + src_vs = varSet[src].vs; + tmp_vs = union_tmp; + tmp_used = 0; + dst_used = varSet[dst].used; + src_used = varSet[src].used; + + /* merge the two sets into tmp */ + pd = ps = 0; + while (pd < dst_used || ps < src_used) { + if (pd == dst_used) + tmp_vs[tmp_used++] = src_vs[ps++]; + else + if (ps == src_used) + tmp_vs[tmp_used++] = dst_vs[pd++]; + else { + StgVar vald = dst_vs[pd]; + StgVar vals = src_vs[ps]; + if (vald < vals) + tmp_vs[tmp_used++] = vald, pd++; + else + if (vald > vals) + tmp_vs[tmp_used++] = vals, ps++; + else + tmp_vs[tmp_used++] = vals, ps++, pd++; + } + } + + /* copy setTmp back to dst */ + varSet[dst].used = tmp_used; + for (i = 0; i < tmp_used; i++) { + dst_vs[i] = tmp_vs[i]; + } +} + + + +/* -------------------------------------------------------------------------- + * Strongly-connected-components machinery for STG let bindings. + * Arranges let bindings in minimal mutually recursive groups, and + * then throws away any groups not referred to in the body of the let. + * + * How it works: does a bottom-up sweep of the tree. Each call returns + * the set of variables free in the tree. All nodes except LETREC are + * boring. + * + * When 'let v1=e1 .. vn=en in e' is encountered: + * -- recursively make a call on e. This returns fvs(e) and scc-ifies + * inside e as well. + * -- do recursive calls for e1 .. en too, giving fvs(e1) ... fvs(en). + * + * Then, using fvs(e1) ... fvs(en), the dependancy graph for v1 ... vn + * can be cheaply computed. Using that, compute the strong components + * and rearrange the let binding accordingly. + * Finally, for each of the strong components, we can use fvs(en) to + * cheaply determine if the component is used in the body of the let, + * and if not, it can be omitted. + * + * oaScc destructively modifies the tree -- when it gets to a let -- + * we need to pass the address of the expression to scc, not the + * (more usual) heap index of it. + * + * The main requirement of this algorithm is an efficient implementation + * of sets of variables. Because there is no name shadowing in these + * trees, either mentioned-sets or free-sets would be ok, although + * free sets are presumably smaller. + * ------------------------------------------------------------------------*/ + + +#define SCC stgScc /* make scc algorithm for StgVars */ +#define LOWLINK stgLowlink +#define DEPENDS(t) thd3(t) +#define SETDEPENDS(c,v) thd3(c)=v +#include "scc.c" +#undef SETDEPENDS +#undef DEPENDS +#undef LOWLINK +#undef SCC + + +StgVarSet oaScc ( StgExpr* e_orig ) +{ + Bool grpUsed; + StgExpr e; + StgVarSet e_fvs, s1, s2; + List bs, bs2, bs3, bsFinal, augs, augsL; + + bs=bs2=bs3=bsFinal=augs=augsL=e_fvs=s1=s2=e=NIL; + grpUsed=FALSE; + + e = *e_orig; + + //fprintf(stderr,"\n==================\n"); + //ppStgExpr(*e_orig); + //fprintf(stderr,"\n\n");fflush(stderr);fflush(stdout); + + + switch(whatIsStg(e)) { + case LETREC: + /* first, recurse into the let body */ + e_fvs = oaScc(&stgLetBody(*e_orig)); + + /* Make bs :: [StgVar] and e :: Stgexpr. */ + bs = stgLetBinds(e); + e = stgLetBody(e); + + /* make augs :: [(StgVar,fvs(bindee),NIL)] */ + augs = NIL; + for (; nonNull(bs); bs=tl(bs)) { + StgVarSet fvs_bindee = oaScc(&stgVarBody(hd(bs))); + augs = cons( triple(hd(bs),mkInt(fvs_bindee),NIL), augs ); + } + + bs2=bs3=bsFinal=augsL=s1=s2=NIL; + + /* In each of the triples in aug, replace the NIL field with + a list of the let-bound vars appearing in the bindee. + ie, construct the adjacency list for the graph. + giving + augs :: [(StgVar,fvs(bindee),[pointers-back-to-this-list-of-pairs])] + */ + for (bs=augs;nonNull(bs);bs=tl(bs)) { + augsL = NIL; + for (bs2=augs;nonNull(bs2);bs2=tl(bs2)) + if (elemStgVarSet( intOf(snd3(hd(bs))), fst3(hd(bs2)) )) + augsL = cons(hd(bs2),augsL); + thd3(hd(bs)) = augsL; + } + + bs2=bs3=bsFinal=augsL=s1=s2=NIL; + + /* Do the Biz. + augs becomes :: [[(StgVar,fvs(bindee),aux_info_field)]] */ + augs = stgScc(augs); + + /* work backwards through augs, reconstructing the expression, + dumping any unused groups as you go. */ - while (v != v1) { - StgRhs r = stgVarBody(v); - assert(whatIs(r) == STGVAR); - stgVarBody(v) = v1; - v = r; - } - return v1; - } - return v; + bsFinal = NIL; + for (augs=rev(augs); nonNull(augs); augs=tl(augs)) { + bs2 = NIL; + for (augsL=hd(augs);nonNull(augsL); augsL=tl(augsL)) + bs2 = cons(fst3(hd(augsL)),bs2); + grpUsed = FALSE; + for (bs3=bs2;nonNull(bs3);bs3=tl(bs3)) + if (elemStgVarSet(e_fvs,hd(bs3))) { grpUsed=TRUE; break; } + if (grpUsed) { + //e = mkStgLet(bs2,e); + bsFinal = dupOnto(bs2,bsFinal); + for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) { + unionStgVarSets(e_fvs, intOf(snd3(hd(augsL))) ); + freeStgVarSet(intOf(snd3(hd(augsL)))); + } + } else { + nLetrecGroupsDropped++; + for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) { + freeStgVarSet(intOf(snd3(hd(augsL)))); + } + } + } + //*e_orig = e; + *e_orig = mkStgLet(bsFinal,e); + return e_fvs; + + case LAMBDA: + s1 = oaScc(&stgLambdaBody(e)); + for (bs=stgLambdaArgs(e);nonNull(bs);bs=tl(bs)) + deleteFromStgVarSet(s1,hd(bs)); + return s1; + case CASE: + s1 = oaScc(&stgCaseScrut(e)); + for (bs=stgCaseAlts(e);nonNull(bs);bs=tl(bs)) { + s2 = oaScc(&hd(bs)); + unionStgVarSets(s1,s2); + freeStgVarSet(s2); + } + return s1; + case PRIMCASE: + s1 = oaScc(&stgPrimCaseScrut(e)); + for (bs=stgPrimCaseAlts(e);nonNull(bs);bs=tl(bs)) { + s2 = oaScc(&hd(bs)); + unionStgVarSets(s1,s2); + freeStgVarSet(s2); + } + return s1; + case STGAPP: + s1 = oaScc(&stgAppFun(e)); + for (bs=stgAppArgs(e);nonNull(bs);bs=tl(bs)) { + s2 = oaScc(&hd(bs)); + unionStgVarSets(s1,s2); + freeStgVarSet(s2); + } + return s1; + case STGPRIM: + s1 = oaScc(&stgPrimOp(e)); + for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) { + s2 = oaScc(&hd(bs)); + unionStgVarSets(s1,s2); + freeStgVarSet(s2); + } + return s1; + case STGCON: + s1 = allocStgVarSet(0); + for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) { + s2 = oaScc(&hd(bs)); + unionStgVarSets(s1,s2); + freeStgVarSet(s2); + } + return s1; + case CASEALT: + s1 = oaScc(&stgCaseAltBody(e)); + for (bs=stgCaseAltVars(e);nonNull(bs);bs=tl(bs)) + deleteFromStgVarSet(s1,hd(bs)); + return s1; + case DEEFALT: + s1 = oaScc(&stgDefaultBody(e)); + deleteFromStgVarSet(s1,stgDefaultVar(e)); + return s1; + case PRIMALT: + s1 = oaScc(&stgPrimAltBody(e)); + for (bs=stgPrimAltVars(e);nonNull(bs);bs=tl(bs)) + deleteFromStgVarSet(s1,hd(bs)); + return s1; + case STGVAR: + s1 = allocStgVarSet(1); + singletonStgVarSet(s1,e); + return s1; + case NAME: + case INTCELL: + case STRCELL: + case PTRCELL: + case BIGCELL: + case CHARCELL: + case FLOATCELL: + return allocStgVarSet(0); + break; + default: + fprintf(stderr, "oaScc: unknown stuff %d\n",whatIsStg(e)); + assert(0); + } } -void optimiseBind( StgVar v ) + + +/* -------------------------------------------------------------------------- + * Occurrence analyser. Marks each let-bound var with the number of times + * it is used, or some number >= OCC_IN_LAMBDA if it is used inside a lambda. + * + * Firstly, oaPre traverses the tree, attaching a mutable INT cell to each + * let bound var, and NIL-ing the counts on all other vars. + * + * Then oaCount traveses the tree. Because variables are represented by + * pointers in the heap, we can just increment the count field of each + * variable we see. However, to deal with lambdas, the Hugs stack holds + * all let-bound variables currently in scope, and the uppermost portion + * of the stack, stack(spBase .. sp) inclusive, denotes the variables + * introduced into scope since the nearest enclosing lambda. When a + * let-bound var is seen, we search stack(spBase .. sp). If it appears + * there, no lambda exists between the binding site and this usage of the + * var, so we can safely increment its use. Otherwise, we must set it to + * OCC_IN_LAMBDA. + * + * When passing a lambda, spBase is set to sp+1, so as to effectively + * empty the set of vars-bound-since-the-latest-lambda. + * + * Because oaPre pre-annotates the tree with mutable INT cells, oaCount + * doesn't allocate any heap at all. + * ------------------------------------------------------------------------*/ + +static int spBase; + + +#define OCC_IN_LAMBDA 50 /* any number > 1 will do */ +#define nullCount(vv) stgVarInfo(vv)=NIL +#define nullCounts(vvs) { List tt=(vvs);for(;nonNull(tt);tt=tl(tt)) nullCount(hd(tt));} + + + +void oaPre ( StgExpr e ) { - StgRhs rhs; - rhs = stgVarBody(v); - switch (whatIs(rhs)) { - case STGCON: - mapOver(optimiseAtom,stgConArgs(rhs)); - break; - default: - stgVarBody(v) = optimiseExpr(rhs); - break; - } + List bs; + switch(whatIsStg(e)) { + case LETREC: + for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs)) + stgVarInfo(hd(bs)) = mkInt(0); + for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs)) + oaPre(stgVarBody(hd(bs))); + oaPre(stgLetBody(e)); + break; + case LAMBDA: + nullCounts(stgLambdaArgs(e)); + oaPre(stgLambdaBody(e)); + break; + case CASE: + oaPre(stgCaseScrut(e)); + mapProc(oaPre,stgCaseAlts(e)); + break; + case PRIMCASE: + oaPre(stgPrimCaseScrut(e)); + mapProc(oaPre,stgPrimCaseAlts(e)); + break; + case STGAPP: + oaPre(stgAppFun(e)); + mapProc(oaPre,stgAppArgs(e)); + break; + case STGPRIM: + mapProc(oaPre,stgPrimArgs(e)); + break; + case STGCON: + mapProc(oaPre,stgConArgs(e)); + break; + case CASEALT: + nullCounts(stgCaseAltVars(e)); + oaPre(stgCaseAltBody(e)); + break; + case DEEFALT: + nullCount(stgDefaultVar(e)); + oaPre(stgDefaultBody(e)); + break; + case PRIMALT: + nullCounts(stgPrimAltVars(e)); + oaPre(stgPrimAltBody(e)); + break; + case STGVAR: + case NAME: + case INTCELL: + case STRCELL: + case PTRCELL: + case BIGCELL: + case CHARCELL: + case FLOATCELL: + break; + default: + fprintf(stderr, "oaPre: unknown stuff %d\n",whatIsStg(e)); + assert(0); + } } -static StgCaseAlt optimiseAlt( StgCaseAlt alt ) -{ - /* StgPat pat = stgCaseAltPat(alt); */ - stgCaseAltBody(alt) = optimiseExpr(stgCaseAltBody(alt)); - return alt; -} - -static StgPrimAlt optimisePrimAlt( StgPrimAlt alt ) -{ - /* List vs = stgPrimAltPats(alt); */ - stgPrimAltBody(alt) = optimiseExpr(stgPrimAltBody(alt)); - return alt; -} - -static StgExpr optimiseExpr( StgExpr e ) -{ - switch (whatIs(e)) { - case LETREC: - { - List binds = stgLetBinds(e); - { - /* First we filter out trivial bindings. - * this has to be done before optimising the individual - * bindings so that we don't get confused by the results - * of other optimisations. - */ - List bs = binds; - binds = NIL; - for(; nonNull(bs); bs=tl(bs)) { - StgVar b = optimiseVar(hd(bs)); - StgRhs rhs = stgVarBody(b); - if (whatIs(rhs) == STGVAR && b != rhs) { - /* This variable will be short-circuited - * by optimiseVar so we can drop the binding - * right now. - */ -fprintf(stderr, "dropping bind ");printStg(stderr,b);fprintf(stderr, "\n"); - } else { -fprintf(stderr, "retaining bind ");printStg(stderr,b);fprintf(stderr, "\n"); - binds = cons(hd(bs),binds); - } - } - binds = rev(binds); /* preserve original order */ - } - stgLetBody(e) = optimiseExpr(stgLetBody(e)); - if (isNull(binds)) { - return stgLetBody(e); - } else { - mapProc(optimiseBind,binds); - stgLetBinds(e) = binds; - } - break; - } - case LAMBDA: - stgLambdaBody(e) = optimiseExpr(stgLambdaBody(e)); - break; - case CASE: - { - StgExpr scrut = optimiseExpr(stgCaseScrut(e)); - StgExpr alts = stgCaseAlts(e); - if (whatIs(scrut) == STGVAR - && whatIs(stgVarBody(scrut)) == STGCON - ) { - StgRhs rhs = stgVarBody(scrut); - StgDiscr d = stgConCon(rhs); - List args = stgConArgs(rhs); - for(; nonNull(alts); alts=tl(alts)) { - StgCaseAlt alt = hd(alts); - StgPat pat = stgCaseAltPat(alt); - if (isDefaultPat(pat)) { /* the easy case */ - StgExpr body = stgCaseAltBody(alt); - stgVarBody(pat) = rhs; - return optimiseExpr(body); - } else if (stgPatDiscr(pat) == d) { - /* The tricky case: - * rebind all the pattern args to the con args - * and rebind the pattern var to con - * and run optimiser (to eliminate the binding) - */ - StgExpr body = stgCaseAltBody(alt); - List binds = stgPatVars(pat); - { - List vs = binds; - for(; - nonNull(vs) && nonNull(args); - vs = tl(vs), args=tl(args) - ) { - stgVarBody(hd(vs)) = hd(args); - } - } - binds = cons(pat,binds); /* turn patvar into a var! */ - stgVarBody(pat) = rhs; - - /* This letrec will always be optimised away */ - body = makeStgLet(binds,body); - return optimiseExpr(body); - } - } - internal("optimiseExpr: no patterns matched"); - } - stgCaseScrut(e) = scrut; - mapOver(optimiseAlt,alts); - break; - } - case PRIMCASE: - mapOver(optimisePrimAlt,stgPrimCaseAlts(e)); - stgPrimCaseScrut(e) = optimiseExpr(stgPrimCaseScrut(e)); - break; - case STGPRIM: - mapOver(optimiseAtom,stgPrimArgs(e)); - /* primop is not a var */ - break; - case STGAPP: - stgAppFun(e) = optimiseExpr(stgAppFun(e)); - mapOver(optimiseAtom,stgAppArgs(e)); - break; - case STGVAR: - return optimiseVar(e); - case NAME: - break; /* Names are never free vars */ - default: - internal("optimiseExpr"); - } - return e; + +/* In oaCount: + -- the stack is always the set of let-bound vars currently + in scope. viz, stack(0 .. sp) inclusive. + -- spBase is always >= 0 and <= sp. + stack(spBase .. sp) inclusive will be the let vars bound + since the nearest enclosing lambda. When entering a lambda, + we set spBase=sp+1 so as record this fact, and restore spBase + afterwards. +*/ +void oaCount ( StgExpr e ) +{ + List bs; + Int spBase_saved; + + switch(whatIsStg(e)) { + case LETREC: + for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs)) + push(hd(bs)); + for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs)) + oaCount(stgVarBody(hd(bs))); + oaCount(stgLetBody(e)); + for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs)) + drop(); + break; + case LAMBDA: + spBase_saved = spBase; + spBase = sp+1; + oaCount(stgLambdaBody(e)); + spBase = spBase_saved; + break; + case CASE: + oaCount(stgCaseScrut(e)); + mapProc(oaCount,stgCaseAlts(e)); + break; + case PRIMCASE: + oaCount(stgPrimCaseScrut(e)); + mapProc(oaCount,stgPrimCaseAlts(e)); + break; + case STGAPP: + oaCount(stgAppFun(e)); + mapProc(oaCount,stgAppArgs(e)); + break; + case STGPRIM: + mapProc(oaCount,stgPrimArgs(e)); + break; + case STGCON: + mapProc(oaCount,stgConArgs(e)); + break; + case CASEALT: + nullCounts(stgCaseAltVars(e)); + oaCount(stgCaseAltBody(e)); + break; + case DEEFALT: + nullCount(stgDefaultVar(e)); + oaCount(stgDefaultBody(e)); + break; + case PRIMALT: + nullCounts(stgPrimAltVars(e)); + oaCount(stgPrimAltBody(e)); + break; + case STGVAR: + if (isInt(stgVarInfo(e))) { + Int i, j; + j = -1; + for (i = sp; i >= spBase; i--) + if (stack(i) == e) { j = i; break; }; + if (j == -1) + stgVarInfo(e) = mkInt(OCC_IN_LAMBDA); else + stgVarInfo(e) = mkInt(1 + intOf(stgVarInfo(e))); + } + break; + case NAME: + case INTCELL: + case STRCELL: + case PTRCELL: + case BIGCELL: + case CHARCELL: + case FLOATCELL: + break; + default: + fprintf(stderr, "oaCount: unknown stuff %d\n",whatIsStg(e)); + assert(0); + } +} + +void stgTopSanity ( char*, StgVar ); + +/* Top level entry point for the occurrence analyser. */ +void oaTop ( StgVar v ) +{ + assert (varSet_nfree == M_VAR_SETS); + freeStgVarSet(oaScc(&stgVarBody(v))); + assert (varSet_nfree == M_VAR_SETS); + oaPre(stgVarBody(v)); + clearStack(); spBase = 0; + oaCount(stgVarBody(v)); + assert(stackEmpty()); + stgTopSanity("oaTop",stgVarBody(v)); +} + + +/* -------------------------------------------------------------------------- + * Transformation machinery proper + * ------------------------------------------------------------------------*/ + +#define streq(aa,bb) (strcmp((aa),(bb))==0) +/* Return TRUE if the non-default alts in the given list are exhaustive. + If in doubt, return FALSE. +*/ +Bool stgAltsExhaustive ( List alts ) +{ + Int nDefnCons; + Name con; + Tycon t; + List cs; + char* s; + List alts0 = alts; + while (nonNull(alts) && isDefaultAlt(hd(alts))) alts=tl(alts); + if (isNull(alts)) { + return FALSE; + } else { + con = stgCaseAltCon(hd(alts)); + /* special case: dictionary constructor */ + if (strncmp("Make.",textToStr(name(con).text),5)==0) + return TRUE; + /* special case: constructor boxing an unboxed value. */ + if (isBoxingCon(con)) + return TRUE; + /* some other special cases which are not boxingCons */ + s = textToStr(name(con).text); + if (streq(s,"Integer#") + || streq(s,"Ref#") + || streq(s,"PrimMutableArray#") + || streq(s,"PrimMutableByteArray#") + || streq(s,"PrimByteArray#") + || streq(s,"PrimArray#") + ) + return TRUE; + if (strcmp("Ref#",textToStr(name(con).text))==0) + return TRUE; + /* special case: Tuples */ + if (isTuple(con) || (isName(con) && con==nameUnit)) + return TRUE; + if (isNull(name(con).parent)) internal("stgAltsExhaustive(1)"); + t = name(con).parent; + cs = tycon(t).defn; + if (tycon(t).what != DATATYPE) internal("stgAltsExhaustive(2)"); + nDefnCons = length(cs); + for (; nonNull(alts0);alts0=tl(alts0)) { + if (isDefaultAlt(hd(alts0))) continue; + nDefnCons--; + } + } + return nDefnCons == 0; +} +#undef streq + + +/* If in doubt, return FALSE. +*/ +Bool isManifestCon ( StgExpr e ) +{ + StgExpr altB; + switch (whatIsStg(e)) { + case STGCON: return TRUE; + case LETREC: return isManifestCon(stgLetBody(e)); + case CASE: if (length(stgCaseAlts(e))==1) { + if (isDefaultAlt(hd(stgCaseAlts(e)))) + altB = stgDefaultBody(hd(stgCaseAlts(e))); else + altB = stgCaseAltBody(hd(stgCaseAlts(e))); + return isManifestCon(altB); + } else { + return FALSE; + } + default: return FALSE; + } +} + + +/* Like isManifestCon, but doesn't give up at non-singular cases */ +Bool constructsCon ( StgExpr e ) +{ + List as; + switch (whatIsStg(e)) { + case STGCON: return TRUE; + case LETREC: return constructsCon(stgLetBody(e)); + case CASE: for (as = stgCaseAlts(e); nonNull(as); as=tl(as)) + if (!constructsCon(hd(as))) return FALSE; + return TRUE; + case PRIMCASE: for (as = stgPrimCaseAlts(e); nonNull(as); as=tl(as)) + if (!constructsCon(hd(as))) return FALSE; + return TRUE; + case CASEALT: return constructsCon(stgCaseAltBody(e)); + case DEEFALT: return constructsCon(stgDefaultBody(e)); + case PRIMALT: return constructsCon(stgPrimAltBody(e)); + default: return FALSE; + } +} + + +/* Inline v in the special case where expr is + case v of C a1 ... an -> E + and v's bindee returns a product constructed with C. + and v does not appear in E + and v does not appear in letDefs (ie, this expr isn't + part of the definition of v. +*/ +void tryLoopbreakerHack ( List letDefs, StgExpr expr ) +{ + List alts; + StgExpr scrut, ee, v_bindee; + StgCaseAlt alt; + + assert (whatIsStg(expr)==CASE); + alts = stgCaseAlts(expr); + scrut = stgCaseScrut(expr); + if (whatIsStg(scrut) != STGVAR || isNull(stgVarBody(scrut))) return; + if (length(alts) != 1 || isDefaultAlt(hd(alts))) return; + if (!stgAltsExhaustive(alts)) return; + alt = hd(alts); + ee = stgCaseAltBody(alt); + if (nonNull(cellIsMember(scrut,letDefs))) return; + + v_bindee = stgVarBody(scrut); + if (!isManifestCon(v_bindee)) return; + + stgCaseScrut(expr) = cloneStgTop(v_bindee); + nLoopBreakersInlined++; +} + + +/* Traverse a tree. Replace let-bound vars marked as used-once + by their definitions. Replace references to top-level + values marked inlineMe with their bodies. Carry around a list + of let-bound variables whose definitions we are currently in + so as to know not to inline let-bound vars in their own + definitions. +*/ +StgExpr copyIn ( List letDefs, InlineCtx ctx, StgExpr e ) +{ + List bs; + + switch(whatIsStg(e)) { + // these are the only two interesting cases + case STGVAR: + assert(isPtr(stgVarInfo(e)) || isNull(stgVarInfo(e)) || + isInt(stgVarInfo(e))); + if (isInt(stgVarInfo(e)) && intOf(stgVarInfo(e))==1) { + nLetvarsInlined++; + return cloneStgTop(stgVarBody(e)); + } else + return e; + case NAME: + // if we're not inlining top vars on this round, do nothing + if (!copyInTopvar) return e; + // if it doesn't want to be inlined, do nothing + if (!name(e).inlineMe) return e; + // we decline to inline dictionary builders inside other builders + if (inDBuilder && name(e).isDBuilder) { + //fprintf(stderr, "decline to inline dbuilder %s\n", textToStr(name(e).text)); + return e; + } + // in fact, only inline dict builders into a case scrutinee + if (name(e).isDBuilder && ctx != CTX_SCRUT) + return e; + +#if DEBUG_OPTIMISE +assert( stgSize(stgVarBody(name(e).stgVar)) == name(e).stgSize ); +#endif + + // only inline large dict builders if it returns a manifest con + if (name(e).isDBuilder && + name(e).stgSize > 180 && + !isManifestCon(stgVarBody(name(e).stgVar))) + return e; +#if 0 + // if it's huge, don't inline into a boring place + if (ctx != CTX_SCRUT && + name(e).stgSize > 270) + return e; +#endif + + nTopvarsInlined++; + return cloneStgTop(stgVarBody(name(e).stgVar)); + + // the rest are a boring recursive traversal of the tree + case LETREC: + stgLetBody(e) = copyIn(letDefs,CTX_OTHER,stgLetBody(e)); + letDefs = dupOnto(stgLetBinds(e),letDefs); + for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs)) + stgVarBody(hd(bs)) = copyIn(letDefs,CTX_OTHER,stgVarBody(hd(bs))); + break; + case LAMBDA: + stgLambdaBody(e) = copyIn(letDefs,CTX_OTHER,stgLambdaBody(e)); + break; + case CASE: + stgCaseScrut(e) = copyIn(letDefs,CTX_SCRUT,stgCaseScrut(e)); + map2Over(copyIn,letDefs,CTX_OTHER,stgCaseAlts(e)); + if (copyInTopvar) tryLoopbreakerHack(letDefs,e); + break; + case PRIMCASE: + stgPrimCaseScrut(e) = copyIn(letDefs,CTX_OTHER,stgPrimCaseScrut(e)); + map2Over(copyIn,letDefs,CTX_OTHER,stgPrimCaseAlts(e)); + break; + case STGAPP: + stgAppFun(e) = copyIn(letDefs,CTX_OTHER,stgAppFun(e)); + break; + case CASEALT: + stgCaseAltBody(e) = copyIn(letDefs,CTX_OTHER,stgCaseAltBody(e)); + break; + case DEEFALT: + stgDefaultBody(e) = copyIn(letDefs,CTX_OTHER,stgDefaultBody(e)); + break; + case PRIMALT: + stgPrimAltBody(e) = copyIn(letDefs,CTX_OTHER,stgPrimAltBody(e)); + break; + case STGPRIM: + case STGCON: + case INTCELL: + case STRCELL: + case PTRCELL: + case CHARCELL: + case FLOATCELL: + break; + default: + fprintf(stderr, "copyIn: unknown stuff %d\n",whatIsStg(e)); + ppStgExpr(e); + printf("\n"); + print(e,1000); + printf("\n"); + assert(0); + } + return e; +} + + + +/* case (C a1 ... an) of + B ... -> ... + C v1 ... vn -> e + D ... -> ... + ==> + e with v1/a1 ... vn/an +*/ +StgExpr doCaseOfCon ( StgExpr expr, Bool* done ) +{ + StgExpr scrut, e; + StgVar apC; + StgCaseAlt theAlt; + List alts, altvs, as, sub; + + *done = FALSE; + alts = stgCaseAlts(expr); + scrut = stgCaseScrut(expr); + + apC = stgConCon(scrut); + + theAlt = NIL; + for (alts = stgCaseAlts(expr); nonNull(alts); alts=tl(alts)) + if (!isDefaultAlt(hd(alts)) && stgCaseAltCon(hd(alts)) == apC) { + theAlt = hd(alts); + break; + } + + if (isNull(theAlt)) return expr; + altvs = stgCaseAltVars(theAlt); + e = stgCaseAltBody(theAlt); + as = stgConArgs(scrut); + + if (length(as)!=length(altvs)) return expr; + + sub = NIL; + while (nonNull(altvs)) { + sub = cons(pair(hd(altvs),hd(as)),sub); + as = tl(as); + altvs = tl(altvs); + } + nCaseOfCon++; + *done = TRUE; + return zubstExpr(sub,e); +} + + +/* case (let binds in e) of alts + ===> + let binds in case e of alts +*/ +StgExpr doCaseOfLet ( StgExpr expr, Bool* done ) +{ + StgExpr letexpr, e; + List binds, alts; + + letexpr = stgCaseScrut(expr); + e = stgLetBody(letexpr); + binds = stgLetBinds(letexpr); + alts = stgCaseAlts(expr); + nCaseOfLet++; + *done = TRUE; + return mkStgLet(binds,mkStgCase(e,alts)); +} + + + +/* case (case e of p1 -> e1 ... pn -> en) of + q1 -> h1 + ... + qk -> hk + ===> + case e of + p1 -> case e1 of q1 -> h1 ... qk -> hk + ... + pn -> case en of q1 -> h1 ... qk -> kl +*/ +StgExpr doCaseOfCase ( StgExpr expr ) +{ + StgExpr innercase, e, tmpcase, protocase; + List ps_n_es, qs_n_hs, newAlts; + StgCaseAlt newAlt, p_n_e; + + nCaseOfCase++; + + innercase = stgCaseScrut(expr); + e = stgCaseScrut(innercase); + ps_n_es = stgCaseAlts(innercase); + qs_n_hs = stgCaseAlts(expr); + + /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */ + protocase = mkStgCase( mkInt(0), qs_n_hs); + + newAlts = NIL; + for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) { + tmpcase = cloneStgTop(protocase); + p_n_e = hd(ps_n_es); + if (isDefaultAlt(p_n_e)) { + stgCaseScrut(tmpcase) = stgDefaultBody(p_n_e); + newAlt = mkStgDefault(stgDefaultVar(p_n_e), tmpcase); + } else { + stgCaseScrut(tmpcase) = stgCaseAltBody(p_n_e); + newAlt = mkStgCaseAlt(stgCaseAltCon(p_n_e),stgCaseAltVars(p_n_e),tmpcase); + } + newAlts = cons(newAlt,newAlts); + } + newAlts = rev(newAlts); + return + mkStgCase(e, newAlts); +} + + + +/* case (case# e of p1 -> e1 ... pn -> en) of + q1 -> h1 + ... + qk -> hk + ===> + case# e of + p1 -> case e1 of q1 -> h1 ... qk -> hk + ... + pn -> case en of q1 -> h1 ... qk -> kl +*/ +StgExpr doCaseOfPrimCase ( StgExpr expr ) +{ + StgExpr innercase, e, tmpcase, protocase; + List ps_n_es, qs_n_hs, newAlts; + StgCaseAlt newAlt, p_n_e; + + nCaseOfPrimCase++; + + innercase = stgCaseScrut(expr); + e = stgPrimCaseScrut(innercase); + ps_n_es = stgPrimCaseAlts(innercase); + qs_n_hs = stgCaseAlts(expr); + + /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */ + protocase = mkStgCase( mkInt(0), qs_n_hs); + + newAlts = NIL; + for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) { + tmpcase = cloneStgTop(protocase); + p_n_e = hd(ps_n_es); + stgPrimCaseScrut(tmpcase) = stgPrimAltBody(p_n_e); + newAlt = mkStgPrimAlt(stgPrimAltVars(p_n_e),tmpcase); + newAlts = cons(newAlt,newAlts); + } + newAlts = rev(newAlts); + return + mkStgPrimCase(e, newAlts); +} + + +Bool isStgCaseWithSingleNonDefaultAlt ( StgExpr e ) +{ + return + whatIsStg(e)==CASE && + length(stgCaseAlts(e))==1 && + !isDefaultAlt(hd(stgCaseAlts(e))); +} + + +/* Do simplifications on an Stg tree. Invariant is that the + input and output trees should have no name shadowing. + + -- let { } in e + ===> + e + + -- dump individual let-bindings with usage counts of zero + + -- dump let-binding groups for which none of the bound vars + occur in the let body + + -- (\v1 ... vn -> e) a1 ... am + ===> + -- the usual beta reduction. There are no constraints on n and m, so + the result can be a lambda term (if n > m), or an application of e + to the unused args (if n < m). + + + Scheme is: bottom-up traversal of the tree. First simplify child + trees. Then try to do local transformations. If a local transformation + succeeds, jump to the local-transformation code for whatever node + is produced -- so as to try and maximise the amount of work which + happens on each call to simplify. +*/ +StgExpr simplify ( List caseEnv, StgExpr e ) +{ + List bs, bs2; + Bool done; + Int n; + + restart: + switch(whatIsStg(e)) { + case STGVAR: + return e; + case NAME: + return e; + + case LETREC: + + /* first dump dead binds, so as not to waste effort simplifying them */ + bs2=NIL; + for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs)) + if (!isInt(stgVarInfo(hd(bs))) || + intOf(stgVarInfo(hd(bs))) > 0) { + bs2=cons(hd(bs),bs2); + } else { + nLetBindsDropped++; + } + if (isNull(bs2)) { e = stgLetBody(e); goto restart; }; + stgLetBinds(e) = rev(bs2); + + for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs)) + stgVarBody(hd(bs)) = simplify(caseEnv,stgVarBody(hd(bs))); + stgLetBody(e) = simplify(caseEnv,stgLetBody(e)); + + /* Merge let ... in let ... in e. Grouping lets together + sometimes reduces the number of iterations needed. + oaScc should do this anyway, but this just to make sure. + */ + while (whatIsStg(stgLetBody(e))==LETREC) { + stgLetBinds(e) = dupOnto(stgLetBinds(stgLetBody(e)),stgLetBinds(e)); + stgLetBody(e) = stgLetBody(stgLetBody(e)); + } + + let_local: + /* let binds in case v-not-in-binds of singleAlt -> expr + ===> + case v-not-in-binds of singleAlt -> let binds in expr + */ + if (isStgCaseWithSingleNonDefaultAlt(stgLetBody(e)) && + whatIsStg(stgCaseScrut(stgLetBody(e)))==STGVAR && + isNull(cellIsMember(stgCaseScrut(stgLetBody(e)),stgLetBinds(e)))) { + StgVar v = stgCaseScrut(stgLetBody(e)); + StgCaseAlt a = hd(stgCaseAlts(stgLetBody(e))); + nLetsFloatedIntoCase++; + e = mkStgCase( + v, + singleton( + mkStgCaseAlt( + stgCaseAltCon(a), + stgCaseAltVars(a), + mkStgLet(stgLetBinds(e),stgCaseAltBody(a)) + ) + ) + ); + assert(whatIsStg(e)==CASE); + goto case_local; + } + + break; + + case LAMBDA: + stgLambdaBody(e) = simplify(caseEnv,stgLambdaBody(e)); + + lambda_local: + while (whatIsStg(stgLambdaBody(e))==LAMBDA) { + nLambdasMerged++; + stgLambdaArgs(e) = appendOnto(stgLambdaArgs(e), + stgLambdaArgs(stgLambdaBody(e))); + stgLambdaBody(e) = stgLambdaBody(stgLambdaBody(e)); + } + break; + + + case CASE: + stgCaseScrut(e) = simplify(caseEnv,stgCaseScrut(e)); + if (isStgCaseWithSingleNonDefaultAlt(e) && + (whatIsStg(stgCaseScrut(e))==STGVAR || + whatIsStg(stgCaseScrut(e))==NAME)) { + List caseEnv2 = cons( + pair(stgCaseScrut(e),stgCaseAltVars(hd(stgCaseAlts(e)))), + caseEnv + ); + map1Over(simplify,caseEnv2,stgCaseAlts(e)); + } else { + map1Over(simplify,caseEnv,stgCaseAlts(e)); + } + + case_local: + /* zap redundant default alternatives */ + if (stgAltsExhaustive(stgCaseAlts(e))) { + Bool droppedDef = FALSE; + bs2 = NIL; + for (bs = dupList(stgCaseAlts(e));nonNull(bs);bs=tl(bs)) + if (!isDefaultAlt(hd(bs))) { + bs2=cons(hd(bs),bs2); + } else { + droppedDef = TRUE; + } + bs2 = rev(bs2); + stgCaseAlts(e) = bs2; + if (droppedDef) nCaseDefaultsDropped++; + } + + switch (whatIsStg(stgCaseScrut(e))) { + case CASE: + /* attempt case-of-case */ + n = length(stgCaseAlts(e)); + if (n==1 || + (n <= 3 && + (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 && + constructsCon(stgCaseScrut(e))) + ) { + e = doCaseOfCase(e); + assert(whatIsStg(e)==CASE); + goto case_local; + } + break; + case PRIMCASE: + /* attempt case-of-case# */ + n = length(stgCaseAlts(e)); + if (n==1 || + (n <= 3 && + (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 && + constructsCon(stgCaseScrut(e))) + ) { + e = doCaseOfPrimCase(e); + assert(whatIsStg(e)==PRIMCASE); + goto primcase_local; + } + break; + case LETREC: + /* attempt case-of-let */ + e = doCaseOfLet(e,&done); + if (done) { assert(whatIsStg(e)==LETREC); goto let_local; }; + break; + case STGCON: + /* attempt case-of-constructor */ + e = doCaseOfCon(e,&done); + /* we don't know what the result is, so can't jump to local */ + break; + case NAME: + case STGVAR: { + /* attempt to remove case on something already cased on */ + List outervs, innervs, sub; + Cell lookupResult; + if (!isStgCaseWithSingleNonDefaultAlt(e)) break; + lookupResult = cellAssoc(stgCaseScrut(e),caseEnv); + if (isNull(lookupResult)) break; + outervs = snd(lookupResult); + nCaseOfOuter++; + sub = NIL; + innervs = stgCaseAltVars(hd(stgCaseAlts(e))); + for (; nonNull(outervs) && nonNull(innervs); + outervs=tl(outervs), innervs=tl(innervs)) + sub = cons(pair(hd(innervs),hd(outervs)),sub); + assert (isNull(outervs) && isNull(innervs)); + return zubstExpr(sub, stgCaseAltBody(hd(stgCaseAlts(e)))); + } + default: + break; + } + break; + case CASEALT: + stgCaseAltBody(e) = simplify(caseEnv,stgCaseAltBody(e)); + break; + case DEEFALT: + stgDefaultBody(e) = simplify(caseEnv,stgDefaultBody(e)); + break; + case PRIMALT: + stgPrimAltBody(e) = simplify(caseEnv,stgPrimAltBody(e)); + break; + case PRIMCASE: + stgPrimCaseScrut(e) = simplify(caseEnv,stgPrimCaseScrut(e)); + map1Over(simplify,caseEnv,stgPrimCaseAlts(e)); + primcase_local: + break; + case STGAPP: { + List sub, formals; + StgExpr subd_body; + StgExpr fun; + List args; + + stgAppFun(e) = simplify(caseEnv,stgAppFun(e)); + map1Over(simplify,caseEnv,stgAppArgs(e)); + + fun = stgAppFun(e); + args = stgAppArgs(e); + + switch (whatIsStg(fun)) { + case STGAPP: + nAppsMerged++; + stgAppArgs(e) = appendOnto(stgAppArgs(fun),args); + stgAppFun(e) = stgAppFun(fun); + break; + case LETREC: + /* (let binds in f) args ==> let binds in (f args) */ + nLetsFloatedOutOfFn++; + e = mkStgLet(stgLetBinds(fun),mkStgApp(stgLetBody(fun),args)); + assert(whatIsStg(e)==LETREC); + goto let_local; + break; + case CASE: + if (length(stgCaseAlts(fun))==1 && + !isDefaultAlt(hd(stgCaseAlts(fun)))) { + StgCaseAlt theAlt = hd(stgCaseAlts(fun)); + /* (case e of alt -> f) args ==> case e of alt -> f args */ + e = mkStgCase( + stgCaseScrut(fun), + singleton(mkStgCaseAlt(stgCaseAltCon(theAlt), + stgCaseAltVars(theAlt), + mkStgApp(stgCaseAltBody(theAlt),args)) + ) + ); + nCasesFloatedOutOfFn++; + assert(whatIsStg(e)==CASE); + goto case_local; + } + break; + case LAMBDA: { + sub = NIL; + formals = stgLambdaArgs(fun); + while (nonNull(formals) && nonNull(args)) { + sub = cons(pair(hd(formals),hd(args)),sub); + formals = tl(formals); + args = tl(args); + } + subd_body = zubstExpr(sub,stgLambdaBody(fun)); + + nBetaReductions++; + assert(isNull(formals) || isNull(args)); + if (isNull(formals) && isNull(args)) { + /* fn and args match exactly */ + e = subd_body; + return e; + } + else + if (isNull(formals) && nonNull(args)) { + /* more args than we could deal with. Build a new Ap. */ + e = mkStgApp(subd_body,args); + return e; + } + else + if (nonNull(formals) && isNull(args)) { + /* partial application. We get a new Lambda */ + e = mkStgLambda(formals,subd_body); + return e; + } + } + break; + default: + break; + } + } + break; + case STGPRIM: + break; + case STGCON: + break; + case INTCELL: + case STRCELL: + case PTRCELL: + case CHARCELL: + case FLOATCELL: + break; + default: + fprintf(stderr, "simplify: unknown stuff %d\n",whatIsStg(e)); + ppStgExpr(e); + printf("\n"); + print(e,1000); + printf("\n"); + assert(0); + } + return e; } -void optimiseTopBind( StgVar v ) +/* Restore STG representation invariants broken by simplify. + -- Let-bind any constructor applications which appear + anywhere other than a let. + -- Let-bind non-atomic case scrutinees (ToDo). +*/ +StgExpr restoreStg ( StgExpr e ) { -if (lastModule() != modulePrelude) { -fflush(stdout); fflush(stderr); -fprintf ( stderr, "------------------------------\n" ); -fflush(stderr); -printStg ( stderr, v ); -fprintf(stderr, "\n" ); + List bs; + StgVar newv; + + if (isNull(e)) return e; + + switch(whatIsStg(e)) { + case LETREC: + for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) { + if (whatIsStg(stgVarBody(hd(bs))) == STGCON) { + /* do nothing */ + } + else + if (whatIsStg(stgVarBody(hd(bs))) == LAMBDA) { + stgLambdaBody(stgVarBody(hd(bs))) + = restoreStg(stgLambdaBody(stgVarBody(hd(bs)))); + } + else { + stgVarBody(hd(bs)) = restoreStg(stgVarBody(hd(bs))); + } + } + stgLetBody(e) = restoreStg(stgLetBody(e)); + break; + case LAMBDA: + /* note that the check in LETREC above ensures we won't + get here for legitimate (let-bound) lambdas. */ + stgLambdaBody(e) = restoreStg(stgLambdaBody(e)); + newv = mkStgVar(e,NIL); + e = mkStgLet(singleton(newv),newv); + break; + case CASE: + stgCaseScrut(e) = restoreStg(stgCaseScrut(e)); + mapOver(restoreStg,stgCaseAlts(e)); + if (!isAtomic(stgCaseScrut(e))) { + newv = mkStgVar(stgCaseScrut(e),NIL); + return mkStgLet(singleton(newv),mkStgCase(newv,stgCaseAlts(e))); + } + break; + case PRIMCASE: + stgPrimCaseScrut(e) = restoreStg(stgPrimCaseScrut(e)); + mapOver(restoreStg,stgPrimCaseAlts(e)); + break; + case STGAPP: + stgAppFun(e) = restoreStg(stgAppFun(e)); + mapOver(restoreStg,stgAppArgs(e)); /* probably incorrect */ + if (!isAtomic(stgAppFun(e))) { + newv = mkStgVar(stgAppFun(e),NIL); + e = mkStgLet(singleton(newv),mkStgApp(newv,stgAppArgs(e))); + } + break; + case STGPRIM: + mapOver(restoreStg,stgPrimArgs(e)); + break; + case STGCON: + /* note that the check in LETREC above ensures we won't + get here for legitimate constructor applications. */ + mapOver(restoreStg,stgConArgs(e)); + newv = mkStgVar(e,NIL); + return mkStgLet(singleton(newv),newv); + break; + case CASEALT: + stgCaseAltBody(e) = restoreStg(stgCaseAltBody(e)); + if (whatIsStg(stgCaseAltBody(e))==LAMBDA) { + newv = mkStgVar(stgCaseAltBody(e),NIL); + stgCaseAltBody(e) = mkStgLet(singleton(newv),newv); + } + break; + case DEEFALT: + stgDefaultBody(e) = restoreStg(stgDefaultBody(e)); + if (whatIsStg(stgDefaultBody(e))==LAMBDA) { + newv = mkStgVar(stgDefaultBody(e),NIL); + stgDefaultBody(e) = mkStgLet(singleton(newv),newv); + } + break; + case PRIMALT: + stgPrimAltBody(e) = restoreStg(stgPrimAltBody(e)); + break; + case STGVAR: + case NAME: + case INTCELL: + case STRCELL: + case PTRCELL: + case CHARCELL: + case FLOATCELL: + break; + default: + fprintf(stderr, "restoreStg: unknown stuff %d\n",whatIsStg(e)); + ppStgExpr(e); + printf("\n"); + assert(0); + } + return e; } -optimiseBind ( v ); -if (lastModule() != modulePrelude) { -printStg ( stderr,v ); -fprintf(stderr, "\n\n" ); -fflush(stderr); + + +StgExpr restoreStgTop ( StgExpr e ) +{ + if (whatIs(e)==LAMBDA) + stgLambdaBody(e) = restoreStg(stgLambdaBody(e)); else + e = restoreStg(e); + return e; } + + +void simplTopRefs ( StgExpr e ) +{ + List bs; + + switch(whatIsStg(e)) { + /* the only interesting case */ + case NAME: + if (name(e).inlineMe && !name(e).simplified) { + /* printf("\n((%d)) request for %s\n",rDepth, textToStr(name(e).text)); */ + name(e).simplified = TRUE; + optimiseTopBind(name(e).stgVar); + /* printf("((%d)) done for %s\n",rDepth, textToStr(name(e).text)); */ + } + break; + case LETREC: + simplTopRefs(stgLetBody(e)); + for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) + simplTopRefs(stgVarBody(hd(bs))); + break; + case LAMBDA: + simplTopRefs(stgLambdaBody(e)); + break; + case CASE: + simplTopRefs(stgCaseScrut(e)); + mapProc(simplTopRefs,stgCaseAlts(e)); + break; + case PRIMCASE: + simplTopRefs(stgPrimCaseScrut(e)); + mapProc(simplTopRefs,stgPrimCaseAlts(e)); + break; + case STGAPP: + simplTopRefs(stgAppFun(e)); + mapProc(simplTopRefs,stgAppArgs(e)); + break; + case STGCON: + mapProc(simplTopRefs,stgConArgs(e)); + break; + case STGPRIM: + simplTopRefs(stgPrimOp(e)); + mapProc(simplTopRefs,stgPrimArgs(e)); + break; + case CASEALT: + simplTopRefs(stgCaseAltBody(e)); + break; + case DEEFALT: + simplTopRefs(stgDefaultBody(e)); + break; + case PRIMALT: + simplTopRefs(stgPrimAltBody(e)); + break; + case INTCELL: + case STRCELL: + case PTRCELL: + case BIGCELL: + case CHARCELL: + case FLOATCELL: + case TUPLE: + case STGVAR: + break; + default: + fprintf(stderr, "simplTopRefs: unknown stuff %d\n",whatIsStg(e)); + ppStgExpr(e); + printf("\n"); + print(e,1000); + printf("\n"); + assert(0); + } +} + +char* maybeName ( StgVar v ) +{ + Name n = nameFromStgVar(v); + if (isNull(n)) return "(unknown)"; + return textToStr(name(n).text); +} + + +/* -------------------------------------------------------------------------- + * Sanity checking (weak :-( + * ------------------------------------------------------------------------*/ + +Bool stgError; + +int stgSanity_checkStack ( StgVar v ) +{ + int i, j; + j = 0; + for (i = 0; i <= sp; i++) + if (stack(i)==v) j++; + return j; +} + +void stgSanity_dropVar ( StgVar v ) +{ + drop(); +} + +void stgSanity_pushVar ( StgVar v ) +{ + if (stgSanity_checkStack(v) != 0) stgError = TRUE; + push(v); +} + + +void stgSanity ( StgExpr e ) +{ + List bs; + + switch(whatIsStg(e)) { + case LETREC: + mapProc(stgSanity_pushVar,stgLetBinds(e)); + stgSanity(stgLetBody(e)); + for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) + stgSanity(stgVarBody(hd(bs))); + mapProc(stgSanity_dropVar,stgLetBinds(e)); + break; + case LAMBDA: + mapProc(stgSanity_pushVar,stgLambdaArgs(e)); + stgSanity(stgLambdaBody(e)); + mapProc(stgSanity_dropVar,stgLambdaArgs(e)); + break; + case CASE: + stgSanity(stgCaseScrut(e)); + mapProc(stgSanity,stgCaseAlts(e)); + break; + case PRIMCASE: + stgSanity(stgPrimCaseScrut(e)); + mapProc(stgSanity,stgPrimCaseAlts(e)); + break; + case STGAPP: + stgSanity(stgAppFun(e)); + mapProc(stgSanity,stgAppArgs(e)); + break; + case STGCON: + stgSanity(stgConCon(e)); + mapProc(stgSanity,stgConArgs(e)); + break; + case STGPRIM: + stgSanity(stgPrimOp(e)); + mapProc(stgSanity,stgPrimArgs(e)); + break; + case CASEALT: + mapProc(stgSanity_pushVar,stgCaseAltVars(e)); + stgSanity(stgCaseAltBody(e)); + mapProc(stgSanity_dropVar,stgCaseAltVars(e)); + break; + case DEEFALT: + stgSanity_pushVar(stgDefaultVar(e)); + stgSanity(stgDefaultBody(e)); + stgSanity_dropVar(stgDefaultVar(e)); + break; + case PRIMALT: + mapProc(stgSanity_pushVar,stgPrimAltVars(e)); + stgSanity(stgPrimAltBody(e)); + mapProc(stgSanity_dropVar,stgPrimAltVars(e)); + break; + case STGVAR: + if (stgSanity_checkStack(e) == 1) break; + if (nonNull(nameFromStgVar(e))) return; + break; + case NAME: + case INTCELL: + case STRCELL: + case PTRCELL: + case CHARCELL: + case FLOATCELL: + case TUPLE: + break; + default: + fprintf(stderr, "stgSanity: unknown stuff %d\n",whatIsStg(e)); + ppStgExpr(e); + printf("\n"); + print(e,1000); + printf("\n"); + assert(0); + } +} + + +void stgTopSanity ( char* caller, StgExpr e ) +{ +return; + clearStack(); + assert(sp == -1); + stgError = FALSE; + stgSanity(e); + assert(sp == -1); + if (stgError) { + fprintf(stderr, "\n\nstgTopSanity (caller = %s):\n\n", caller ); + ppStgExpr ( e ); + printf( "\n\n" ); + assert(0); + } +} + + +/* Check if e is in a form which the code generator can deal with. + * stgexpr-ness is what we need to enforce. The extended version, + * expr, may only occur as the rhs of a let binding. + * + * stgexpr ::= case atom of alts + * | case# primop{atom*} of primalts + * | let v_i = expr_i in stgexpr + * | var{atom*} + * + * expr ::= stgexpr + * | \v_i -> stgexpr + * | con{atoms} + * + * alt ::= con vars -> stgexpr (primalt and default similarly) + * + * atom ::= var | int | char etc (unboxed, that is) + */ +Bool isStgExpr ( StgExpr e ); +Bool isStgFullExpr ( StgExpr e ); + +Bool isStgExpr ( StgExpr e ) +{ + List bs; + switch (whatIs(e)) { + case LAMBDA: + case STGCON: + return FALSE; + case LETREC: + for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) + if (!isStgFullExpr(stgVarBody(hd(bs)))) + return FALSE; + return isStgExpr(stgLetBody(e)); + case CASE: + for (bs=stgCaseAlts(e); nonNull(bs); bs=tl(bs)) + if (!isStgExpr(hd(bs))) return FALSE; + return isAtomic(stgCaseScrut(e)); + case PRIMCASE: + for (bs=stgPrimCaseAlts(e); nonNull(bs); bs=tl(bs)) + if (!isStgExpr(hd(bs))) return FALSE; + if (isAtomic(stgPrimCaseScrut(e))) return TRUE; + if (whatIs(stgPrimCaseScrut(e))==STGPRIM) + return isStgExpr(stgPrimCaseScrut(e)); + return FALSE; + case STGVAR: + case NAME: + return TRUE; + case STGAPP: + for (bs=stgAppArgs(e); nonNull(bs); bs=tl(bs)) + if (!isAtomic(hd(bs))) return FALSE; + if (isStgVar(stgAppFun(e)) || isName(stgAppFun(e))) return TRUE; + return FALSE; + case STGPRIM: + for (bs=stgPrimArgs(e); nonNull(bs); bs=tl(bs)) + if (!isAtomic(hd(bs))) return FALSE; + if (isName(stgPrimOp(e))) return TRUE; + return FALSE; + case CASEALT: + return isStgExpr(stgCaseAltBody(e)); + case DEEFALT: + return isStgExpr(stgDefaultBody(e)); + case PRIMALT: + return isStgExpr(stgPrimAltBody(e)); + default: + return FALSE; + } +} + + +Bool isStgFullExpr ( StgExpr e ) +{ + List bs; + switch (whatIs(e)) { + case LAMBDA: + return isStgExpr(stgLambdaBody(e)); + case STGCON: + for (bs=stgConArgs(e); nonNull(bs); bs=tl(bs)) + if (!isAtomic(hd(bs))) return FALSE; + if (isName(stgConCon(e)) || isTuple(stgConCon(e))) + return TRUE; + return FALSE; + default: + return isStgExpr(e); + } +} + + +/* -------------------------------------------------------------------------- + * Top level calls + * ------------------------------------------------------------------------*/ + +/* Set ddumpSimpl to TRUE if you want to see simplified code. */ +static Bool ddumpSimpl = FALSE; + +/* Leave this one alone ... */ +static Bool noisy; + + +static void local optimiseTopBind( StgVar v ) +{ + Bool ppPrel = FALSE; + Int n, m; + Name naam; + Int oldSize, newSize; + Bool me; + + /* printf( "[[%d]] looking at %s\n", rDepth, maybeName(v)); */ + assert(whatIsStg(v)==STGVAR); + + rDepth++; + if (nonNull(stgVarBody(v))) simplTopRefs(stgVarBody(v)); + rDepth--; + + /* debugging ... */ + //me= 0&& 0==strcmp("tcUnify",maybeName(v)); + me= 0&& 0==strcmp("ttt",maybeName(v)); + + nTotSizeIn += stgSize(stgVarBody(v)); + if (noisy) { + printf( "%28s: in %4d ", maybeName(v),stgSize(stgVarBody(v))); + fflush(stdout); + } + + inDBuilder = FALSE; + naam = nameFromStgVar(v); + if (nonNull(naam) && name(naam).isDBuilder) inDBuilder = TRUE; + +#if DEBUG_OPTIMISE + if (nonNull(naam)) { + assert(name(naam).stgSize == stgSize(stgVarBody(name(naam).stgVar))); + } +#endif + + if (me) { + fflush(stdout); fflush(stderr); + fprintf ( stderr, "{{%d}}-----------------------------\n", -v );fflush(stderr); + printStg ( stderr, v ); + fprintf(stderr, "\n" ); + } + + stgTopSanity ( "initial", stgVarBody(v)); + + if (nonNull(stgVarBody(v))) { + oldSize = -1; + + for (n = 0; n < 8; n++) { // originally 7 + if (noisy) printf("%4d", stgSize(stgVarBody(v))); + copyInTopvar = TRUE; + stgTopSanity ( "outer-1", stgVarBody(v)); + oaTop ( v ); + stgTopSanity ( "outer-2", stgVarBody(v)); + stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) ); + stgTopSanity ( "outer-3", stgVarBody(v)); + stgVarBody(v) = simplify ( NIL, stgVarBody(v) ); + stgTopSanity ( "outer-4", stgVarBody(v)); + + for (m = 0; m < 3; m++) { // oprignally 3 + if (noisy) printf("."); + fflush(stdout); + copyInTopvar = FALSE; + stgTopSanity ( "inner-1", stgVarBody(v)); + oaTop ( v ); + stgTopSanity ( "inner-2", stgVarBody(v)); + stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) ); + stgTopSanity ( "inner-3", stgVarBody(v)); + stgVarBody(v) = simplify ( NIL, stgVarBody(v) ); + + if (me && 0) { + fprintf(stderr,"\n-%d- - - - - - - - - - - - - -\n", n+1); + printStg ( stderr,v ); + } + stgTopSanity ( "inner-post", stgVarBody(v)); + + } + + if (me && 1) { + fprintf(stderr,"\n-%d-=-=-=-=-=-=-=-=-=-=-=-=-=-\n", n+1); + printStg ( stderr,v ); + } + + stgTopSanity ( "outer-post", stgVarBody(v)); + + newSize = stgSize ( stgVarBody(v) ); + if (newSize == oldSize) break; + oldSize = newSize; + } + n++; for (; n < 8; n++) for (m = 0; m <= 3+3; m++) if (noisy) printf ( " " ); + if (noisy) printf(" --> %4d\n", stgSize(stgVarBody(v)) ); + stgVarBody(v) = restoreStgTop ( stgVarBody(v) ); + + if (nonNull(naam)) { + assert(name(naam).stgVar == v); + name(naam).stgSize = stgSize(stgVarBody(v)); + } + +#if DEBUG_OPTIMISE + /* debugging ... */ + if (!isStgFullExpr(stgVarBody(v))) { + fprintf(stderr, "\n\nrestoreStg failed!\n\n" ); + printStg(stderr, v); + fprintf(stderr, "\n" ); + exit(1); + } +#endif + } + + nTotSizeOut += stgSize(stgVarBody(v)); + + if (me) { + fprintf(stderr,"\n=============================\n"); + printStg ( stderr,v ); + fprintf(stderr, "\n\n" ); + fflush(stderr); + if (me) exit(1); + } +} + + +void optimiseTopBinds ( List bs ) +{ + List t; + Name n; + Target ta = 0; + + noisy = ddumpSimpl && (lastModule() != modulePrelude); + + optimiser(RESET); + if (noisy) printf("\n"); + initOptStats(); + + for (t = bs; nonNull(t); t=tl(t)) { + n = nameFromStgVar(hd(t)); + if (isNull(n) || !name(n).simplified) { + rDepth = 0; + optimiseTopBind(hd(t)); + } + soFar(ta++); + } + if (noisy) printOptStats ( stderr ); + optimiser(RESET); +} + + +/* -------------------------------------------------------------------------- + * Optimiser control: + * ------------------------------------------------------------------------*/ + +Void optimiser(what) +Int what; { + + switch (what) { + case INSTALL : + case RESET : spClone = SP_NOT_IN_USE; + initStgVarSets(); + daSccs = NIL; + break; + + case MARK : markPairs(); + markStgVarSets(); + mark(daSccs); + break; + + case GCDONE : checkStgVarSets(); + break; + } } /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/output.c b/ghc/interpreter/output.c index 8cf7aa9..dbd6cd1 100644 --- a/ghc/interpreter/output.c +++ b/ghc/interpreter/output.c @@ -9,8 +9,8 @@ * in the distribution for details. * * $RCSfile: output.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:50 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:06:57 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -190,15 +190,6 @@ Cell e; { } break; -#if BIGNUMS - case NEGNUM : - case ZERONUM : - case POSNUM : xs = bigOut(e,NIL,d>=UMINUS_PREC); - for (; nonNull(xs); xs=tl(xs)) - putChr(charOf(arg(hd(xs)))); - break; -#endif - case FLOATCELL : { Float f = floatOf(e); if (f<0 && d>=UMINUS_PREC) putChr('('); putStr(floatToString(f)); @@ -403,9 +394,6 @@ Cell e; { case NAME : if (args==1 && ((h==nameFromInt && isInt(arg(e))) || -#if BIGNUMS - (h==nameFromInteger && isBignum(arg(e))) || -#endif (h==nameFromDouble && isFloat(arg(e))))) { put(d,arg(e)); return; diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index c54fb2c..60e565c 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -11,8 +11,8 @@ * in the distribution for details. * * $RCSfile: parser.y,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/09 14:51:09 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:06:58 $ * ------------------------------------------------------------------------*/ %{ @@ -28,11 +28,7 @@ #define only(t) ap(ONLY,t) #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e) #define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t) -#if IGNORE_MODULES -#define exportSelf() NIL -#else #define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text))) -#endif #define yyerror(s) /* errors handled elsewhere */ #define YYSTYPE Cell diff --git a/ghc/interpreter/preds.c b/ghc/interpreter/preds.c index 43d2f81..1dd37f1 100644 --- a/ghc/interpreter/preds.c +++ b/ghc/interpreter/preds.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: preds.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:50 $ + * $Revision: 1.5 $ + * $Date: 1999/04/27 10:06:59 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -694,9 +694,6 @@ Int vn; { /* variable vn can be resolved */ aNumClass = TRUE; else if (c!=classEq && c!=classOrd && c!=classShow && c!=classRead && c!=classIx && c!=classEnum && -#if EVAL_INSTANCES - c!=classEval && -#endif c!=classBounded) return FALSE; diff --git a/ghc/interpreter/runallnofib b/ghc/interpreter/runallnofib new file mode 100644 index 0000000..754e30a --- /dev/null +++ b/ghc/interpreter/runallnofib @@ -0,0 +1,119 @@ +#!/bin/bash +if ! [ -d nofibtmp ] +then +echo "runallnofib: Can't cd to nofibtmp" +exit +fi + +TROOT=/home/v-julsew/Mar09 +NROOT=$TROOT/fpO/nofib + +cd nofibtmp + + +##------ imaginary ------## + +../runnofib imaginary exp3_8 +../runnofib imaginary gen_regexps +../runnofib imaginary paraffins +../runnofib imaginary primes +../runnofib imaginary rfib +../runnofib imaginary tak +../runnofib imaginary wheel-sieve1 +../runnofib imaginary wheel-sieve2 + + +##------ spectral ------## + +../runnofib spectral ansi +../runnofib spectral awards +../runnofib spectral boyer +../runnofib spectral boyer2 +../runnofib spectral calendar 1993 +../runnofib spectral cichelli +../runnofib spectral circsim "+RTS -H150m -RTS 8 1000" +../runnofib spectral clausify +../runnofib spectral cse +../runnofib spectral eliza + +cp $NROOT/spectral/expert/animals . +../runnofib spectral expert +rm animals + +##../runnofib spectral fibheaps -- requires -fglasgow-exts + +../runnofib spectral fish +../runnofib spectral fft2 +../runnofib spectral life +../runnofib spectral knights 8 3 +../runnofib spectral mandel +../runnofib spectral mandel2 +../runnofib spectral minimax +../runnofib spectral multiplier +../runnofib spectral pretty +../runnofib spectral primetest +../runnofib spectral rewrite +../runnofib spectral scc +../runnofib spectral simple +../runnofib spectral sorting + +cp $NROOT/spectral/treejoin/27000.1 . +cp $NROOT/spectral/treejoin/27000.2 . +../runnofib spectral treejoin "+RTS -H200m -G4 -A1m -RTS 27000.1 27000.2" +rm 27000.1 27000.2 + +../runnofib spectral/hartel nucleic2 + +##------ real ------## + +export ANNADIR=`pwd` +cp $NROOT/real/anna/anna_table . +../runnofib real anna +rm anna_table + +../runnofib real bspt +../runnofib real compress +##../runnofib real compress2 -- requires -fglasgow-exts + +cp $NROOT/real/ebnf2ps/Times-Roman.afm . +cp $NROOT/real/ebnf2ps/ebnf2ps.stdin . +../runnofib real ebnf2ps "ebnf2ps.stdin apat" +rm Times-Roman.afm ebnf2ps.stdin + +../runnofib real fem + +cp $NROOT/real/fluid/chan8.dat . +../runnofib real fluid +rm chan8.dat + +../runnofib real fulsom 7 +../runnofib real gamteb +../runnofib real gg +../runnofib real grep + +cp $NROOT/real/hidden/objects/four.plate . +../runnofib real hidden four.plate +rm four.plate + +##../runnofib real HMMS -- a mess. requires some effort to make it work +../runnofib real hpg "-nt 8 -dt 6 -nv 15 -dv 8 -de 8" +../runnofib real infer +../runnofib real lift + +cp $NROOT/real/maillist/addresses . +../runnofib real maillist +rm addresses addresses.tex + +../runnofib real mkhprog "-a Int -b Float -c Foo -d Bar -e Double -f String -g String -h Int -j Double -k Bool -n Basil -p Knob -q Wizzle -r Wissle -s Wibble -t Widdle -A Int -B Float -C Foo -D Bar -E Double -F String -G String -H Int -I Float -J Double -K Bool -L Bool -M Buzzle -N Basil -P Knob -Q Wizzle -R Wissle -S Wibble -T Widdle" + +../runnofib real parser +../runnofib real pic + +cp $NROOT/real/prolog/stdlib . +../runnofib real prolog +rm stdlib + +../runnofib real reptile +../runnofib real rsa +../runnofib real symalg +../runnofib real veritas diff --git a/ghc/interpreter/runnofib b/ghc/interpreter/runnofib new file mode 100644 index 0000000..7fe123f --- /dev/null +++ b/ghc/interpreter/runnofib @@ -0,0 +1,51 @@ +#!/bin/bash + +TROOT=/home/v-julsew/Mar09 + +STGHUGSFLAGS=-P$TROOT/fpO/ghc/interpreter/lib +NROOT=$TROOT/fpO/nofib +HUGZ=$TROOT/fpO/ghc/interpreter +LD_LIBRARY_PATH=$HUGZ:$LD_LIBRARY_PATH +HSCPP=$TROOT/fpO/ghc/utils/hscpp + +echo +echo "==================== $1/$2 ====================" + +TMPFILE=`mktemp /tmp/nofibXXXXXX` +if [ $? -ne 0 ]; then + echo "$0: Can't create temp file" + exit 1 +fi + +if [ -f $NROOT/$1/$2/$2.stdin ] +then +echo "$HUGZ/hugs +Q $NROOT/$1/$2/Main*hs -- $3 $4 $5 $6 $7 $8 $9" +echo " < $NROOT/$1/$2/$2.stdin 2> /dev/null" +echo " > $TMPFILE" +else +echo "$HUGZ/hugs +Q $NROOT/$1/$2/Main*hs -- $3 $4 $5 $6 $7 $8 $9" +echo " < /dev/null 2> /dev/null" +echo " > $TMPFILE" +fi + +if [ -f $NROOT/$1/$2/$2.stdin ] +then +$HUGZ/hugs +Q $NROOT/$1/$2/Main*hs -- $3 $4 $5 $6 $7 $8 $9 < $NROOT/$1/$2/$2.stdin 2> /dev/null > $TMPFILE +else +$HUGZ/hugs +Q $NROOT/$1/$2/Main*hs -- $3 $4 $5 $6 $7 $8 $9 < /dev/null 2> /dev/null > $TMPFILE +fi + +if [ $? -ne 0 ]; then + echo "=== FAIL (no execution)" + rm -f $TMPFILE + exit 0 +fi + +cmp -s $TMPFILE $NROOT/$1/$2/$2.stdout +if [ $? -ne 0 ]; then + echo "=== FAIL (wrong results)" +else + echo "=== Correct" +fi + +rm -f $TMPFILE diff --git a/ghc/interpreter/sainteger.c b/ghc/interpreter/sainteger.c new file mode 100644 index 0000000..837cf33 --- /dev/null +++ b/ghc/interpreter/sainteger.c @@ -0,0 +1,968 @@ + +/* -------------------------------------------------------------------------- + * Yet another implementation of Integer + * + * Copyright (c) Glasgow University, 1999. + * All rights reserved. See NOTICE for details and conditions of use etc... + * ------------------------------------------------------------------------*/ + +#include +#include +#include +#include + +#include "sainteger.h" + + +/* -------------------------------------------------------------------------- + * Local fns + * ------------------------------------------------------------------------*/ + +typedef unsigned char uchar; +typedef unsigned short ush; + + +static int maxused_add ( B*, B* ); +static int maxused_sub ( B*, B* ); +static int maxused_mul ( B*, B* ); +static int maxused_qrm ( B*, B* ); +static int maxused_neg ( B* ); + +static int ucmp ( B*, B* ); +static void uadd ( B*, B*, B* ); +static void usub ( B*, B*, B* ); +static void umul ( B*, B*, B* ); +static void uqrm ( B*, B*, B*, B* ); + +/*#define DEBUG_SAINTEGER*/ +/*#define DEBUG_SAINTEGER_UQRM*/ + + +#ifdef DEBUG_SAINTEGER +#define myassert(zzzz) assert(zzzz) +#else +#define myassert(zzzz) /* */ +#endif + + +/* -------------------------------------------------------------------------- + * Basics + * ------------------------------------------------------------------------*/ + +void pp ( B* x ) +{ + int i; + printf ( "sign=%2d used=%d size=%d ", x->sign, x->used, x->size ); + for (i = x->used-1; i >= 0; i--) + printf ( "%2x ", (int)(x->stuff[i]) ); + printf ( "\n" ); +} + + +static int sane ( B* x ) +{ + int i; + + if (x->sign == 0 && x->used != 0) return 0; + if (x->sign != -1 && x->sign != 0 && x->sign != 1) return 0; + + if (x->used < 0) return 0; + if (x->size < 0) return 0; + if (x->used > x->size) return 0; + if (x->used == 0) return 1; + if (x->stuff[x->used-1] == 0) return 0; + for (i = 0; i < x->used; i++) + if (x->stuff[i] >= B_BASE) return 0; + return 1; +} + + +int is_sane ( B* x ) +{ + return sane(x); +} + + +static void u_renormalise ( B* b ) +{ + while (b->used > 0 && b->stuff[b->used-1] == 0) b->used--; + if (b->used == 0) b->sign = 0; else b->sign = 1; +} + + +void do_renormalise ( B* b ) +{ + while (b->used > 0 && b->stuff[b->used-1] == 0) b->used--; + if (b->used == 0) b->sign = 0; +} + +/* -------------------------------------------------------------------------- + * Size of things + * ------------------------------------------------------------------------*/ + +static int maxused_add ( B* x, B* y ) +{ + myassert(sane(x)); + myassert(sane(y)); + return 1 + (x->used > y->used ? x->used : y->used); +} + +static int maxused_sub ( B* x, B* y ) +{ + myassert(sane(x)); + myassert(sane(y)); + return 1 + (x->used > y->used ? x->used : y->used); +} + +static int maxused_mul ( B* x, B* y ) +{ + myassert(sane(x)); + myassert(sane(y)); + return x->used + y->used; +} + +static int maxused_qrm ( B* x, B* y ) +{ + myassert(sane(x)); + myassert(sane(y)); + return (x->used > y->used ? x->used : y->used); +} + +static int maxused_neg ( B* x ) +{ + myassert(sane(x)); + return x->used; +} + + +/* quick, safe approx */ +static int maxused_fromInt ( int sizeof_int ) +{ + if (B_BASE == 256) return sizeof_int; + if (B_BASE >= 16) return 2 * sizeof_int; + if (B_BASE >= 4) return 4 * sizeof_int; + /* (B_BASE >= 2) */ return 8 * sizeof_int; +} + +/* ditto */ +static int maxused_fromStr ( char* str ) +{ + int nd = 0; + if (*str == '-') str++; + while (isdigit((int)(*str))) { str++; nd++; }; + + if (B_BASE >= 100) return ((nd+1) / 2); + if (B_BASE >= 10) return nd; + /* (B_BASE >= 2)*/ return 4 * nd; +} + + +int size_add ( B* x, B* y ) +{ + return sizeof(B) + maxused_add(x,y); +} + +int size_sub ( B* x, B* y ) +{ + return sizeof(B) + maxused_sub(x,y); +} + +int size_mul ( B* x, B* y ) +{ + return sizeof(B) + maxused_mul(x,y); +} + +int size_qrm ( B* x, B* y ) +{ + return sizeof(B) + maxused_qrm(x,y); +} + +int size_neg ( B* x ) +{ + return sizeof(B) + maxused_neg(x); +} + +int size_fromInt ( void ) +{ + int sizeof_int = sizeof(int); + return sizeof(B) + maxused_fromInt ( sizeof_int ); +} + +int size_fromWord ( void ) +{ + int sizeof_word = sizeof(unsigned int); + return sizeof(B) + maxused_fromInt ( sizeof_word ); +} + +int size_fromStr ( char* str ) +{ + return sizeof(B) + maxused_fromStr ( str ); +} + +int size_fltmantissa ( void ) +{ + return sizeof(B) + sizeof(float); +} + +int size_dblmantissa ( void ) +{ + return sizeof(B) + sizeof(double); +} + + +/* -------------------------------------------------------------------------- + * Conversions + * ------------------------------------------------------------------------*/ + +void do_fromInt ( int n, int sizeRes, B* res ) +{ + + res->size = sizeRes - sizeof(B); + res->sign = res->used = 0; + if (n == 0) { myassert(sane(res)); return; }; + if (n < 0) res->sign = -1; else res->sign = 1; + if (n < 0) n = -n; + + while (n != 0) { + res->stuff[res->used] = (uchar)(n % B_BASE); + n /= B_BASE; + res->used++; + } + myassert(sane(res)); +} + +void do_fromWord ( unsigned int n, int sizeRes, B* res ) +{ + + res->size = sizeRes - sizeof(B); + res->sign = res->used = 0; + if (n == 0) { myassert(sane(res)); return; }; + res->sign = 1; + + while (n != 0) { + res->stuff[res->used] = (uchar)(n % B_BASE); + n /= B_BASE; + res->used++; + } + myassert(sane(res)); +} + +/* NOTE: This only works currectly if B_BASE >= 10 */ +void do_fromStr ( char* str, int sizeRes, B* res ) +{ + int sign, d, t, j, carry; + + res->size = sizeRes - sizeof(B); + res->sign = res->used = 0; + sign = 1; + if (*str == '-') { str++; sign = -1; }; + + while (isdigit((int)(*str))) { + + /* multiply res by 10 */ + carry = 0; + for (j = 0; j < res->used; j++) { + t = 10 * res->stuff[j] + carry; + res->stuff[j] = t % B_BASE; + carry = t / B_BASE; + } + myassert(carry < B_BASE); + if (carry > 0) + res->stuff[res->used++] = carry; + + /* add a digit on */ + d = *str - '0'; + str++; + + carry = d; + for (j = 0; j < res->used; j++) { + carry += res->stuff[j]; + res->stuff[j] = carry % B_BASE; + carry /= B_BASE; + if (carry == 0) break; + } + if (carry > 0) + res->stuff[res->used++] = carry; + } + + res->sign = sign; + myassert(sane(res)); +} + +int do_toInt ( B* x ) +{ + int i, d, res; + if (x->sign == 0) return 0; + res = 0; + for (i = x->used-1; i >= 0; i--) { + d = x->stuff[i]; + res = res * B_BASE + d; + } + if (x->sign < 0) res = -res; + return res; +} + +unsigned int do_toWord ( B* x ) +{ + int i, d; + unsigned int res; + if (x->sign == 0) return 0; + res = 0; + for (i = x->used-1; i >= 0; i--) { + d = x->stuff[i]; + res = res * B_BASE + d; + } + return res; +} + +float do_toFloat ( B* x ) +{ + int i, d; + float res; + if (x->sign == 0) return 0.0; + res = 0.0; + for (i = x->used-1; i >= 0; i--) { + d = x->stuff[i]; + res = res * B_BASE_FLT + d; + } + if (x->sign < 0) res = -res; + return res; +} + +double do_toDouble ( B* x ) +{ + int i, d; + double res; + if (x->sign == 0) return 0.0; + res = 0.0; + for (i = x->used-1; i >= 0; i--) { + d = x->stuff[i]; + res = res * B_BASE_FLT + d; + } + if (x->sign < 0) res = -res; + return res; +} + + +/* -------------------------------------------------------------------------- + * Signed ops + * ------------------------------------------------------------------------*/ + +/* A helper for signed + and -. sdiff(x,y) ignores the signs of x and y + sets p to the signed value abs(x)-abs(y). +*/ +static void sdiff ( B* x, B* y, B* res ) +{ + int t; + myassert(sane(x)); + myassert(sane(y)); + myassert(res->size == maxused_sub(x,y)); + t = ucmp(x,y); + if (t == 0) { res->sign = res->used = 0; return; } + if (t == -1) { + /* x < y */ + usub(y,x,res); + res->sign = -1; + } else { + /* x > y */ + usub(x,y,res); + res->sign = 1; + } + myassert(sane(res)); +} + +int do_getsign ( B* x ) +{ + myassert(sane(x)); + return x->sign; +} + +void do_neg ( B* x, int sizeRes, B* res ) +{ + int i; + myassert(sane(x)); + res->size = sizeRes - sizeof(B); + res->used = x->used; + for (i = 0; i < x->used; i++) + res->stuff[i] = x->stuff[i]; + res->sign = - (x->sign); +} + +void do_add ( B* x, B* y, int sizeRes, B* res ) +{ + myassert(sane(x)); + myassert(sane(y)); + res->size = sizeRes - sizeof(B); + res->used = res->sign = 0; + + if ( (x->sign >= 0 && y->sign >= 0) || + (x->sign < 0 && y->sign < 0)) { + /* same sign; add magnitude and clone sign */ + uadd(x,y,res); + if (x->sign < 0 && res->sign != 0) res->sign = -1; + } + else + /* signs differ; employ sdiff */ + if (x->sign >= 0 && y->sign < 0) { + sdiff(x,y,res); + } else { + myassert(x->sign < 0 && y->sign >= 0); + sdiff(y,x,res); + } + myassert(sane(res)); +} + +void do_sub ( B* x, B* y, int sizeRes, B* res ) +{ + myassert(sane(x)); + myassert(sane(y)); + res->size = sizeRes - sizeof(B); + res->used = res->sign = 0; + + if ( (x->sign >= 0 && y->sign < 0) || + (x->sign < 0 && y->sign >= 0)) { + /* opposite signs; add magnitudes and clone sign of x */ + uadd(x,y,res); + myassert(res->sign != 0); + if (x->sign < 0) res->sign = -1; + } + else + /* signs are the same; employ sdiff */ + if (x->sign >= 0 && y->sign >= 0) { + sdiff(x,y,res); + } else { + myassert(x->sign < 0 && y->sign < 0); + sdiff(y,x,res); + } + myassert(sane(res)); +} + + +void do_mul ( B* x, B* y, int sizeRes, B* res ) +{ + myassert(sane(x)); + myassert(sane(y)); + res->size = sizeRes - sizeof(B); + res->used = res->sign = 0; + + if (x->sign == 0 || y->sign == 0) { + res->sign = res->used = 0; + myassert(sane(res)); + return; + } + umul(x,y,res); + if (x->sign != y->sign) res->sign = -1; + myassert(sane(res)); +} + + +void do_qrm ( B* x, B* y, int sizeRes, B* q, B* r ) +{ + myassert(sane(x)); + myassert(sane(y)); + + q->size = r->size = sizeRes - sizeof(B); + q->used = r->used = q->sign = r->sign = 0; + + if (y->sign == 0) { + fprintf(stderr, "do_qrm: division by zero -- exiting now!\n"); + exit(1); + return; + } + + if (x->sign == 0) { + q->used = r->used = q->sign = r->sign = 0; + myassert(sane(q)); myassert(sane(r)); + return; + } + + uqrm ( x, y, q, r ); + if (x->sign != y->sign && q->sign != 0) q->sign = -1; + if (x->sign == -1 && r->sign != 0) r->sign = -1; + + myassert(sane(q)); myassert(sane(r)); +} + +int do_cmp ( B* x, B* y ) +{ + if (!sane(x)) + pp(x); + myassert(sane(x)); + myassert(sane(y)); + if (x->sign < y->sign) return -1; + if (x->sign > y->sign) return 1; + myassert(x->sign == y->sign); + if (x->sign == 0) return 0; + if (x->sign == 1) return ucmp(x,y); else return ucmp(y,x); +} + + +/* -------------------------------------------------------------------------- + * Unsigned ops + * ------------------------------------------------------------------------*/ + +static int ucmp ( B* x, B* y ) +{ + int i; + myassert(sane(x)); + myassert(sane(y)); + if (x->used < y->used) return -1; + if (x->used > y->used) return 1; + for (i = x->used-1; i >= 0; i--) { + if (x->stuff[i] < y->stuff[i]) return -1; + if (x->stuff[i] > y->stuff[i]) return 1; + } + return 0; +} + + + +static void uadd ( B* x, B* y, B* res ) +{ + int c, i, t, n; + B* longer; + + myassert(sane(x)); + myassert(sane(y)); + myassert (res->size == maxused_add(x,y)); + res->used = res->size; + res->stuff[res->used-1] = 0; + + if (x->used > y->used) { + n = y->used; + longer = x; + } else { + n = x->used; + longer = y; + } + + c = 0; + for (i = 0; i < n; i++) { + t = x->stuff[i] + y->stuff[i] + c; + if (t >= B_BASE) { + res->stuff[i] = t-B_BASE; + c = 1; + } else { + res->stuff[i] = t; + c = 0; + } + } + + for (i = n; i < longer->used; i++) { + t = longer->stuff[i] + c; + if (t >= B_BASE) { + res->stuff[i] = t-B_BASE; + } else { + res->stuff[i] = t; + c = 0; + } + } + if (c > 0) { + myassert(res->used == longer->used+1); + res->stuff[longer->used] = c; + } + + u_renormalise(res); + myassert(sane(res)); +} + + +static void usub ( B* x, B* y, B* res ) +{ + int b, i, t; + myassert(sane(x)); + myassert(sane(y)); + myassert (x->used >= y->used); + myassert (res->size == maxused_sub(x,y)); + + b = 0; + for (i = 0; i < y->used; i++) { + t = x->stuff[i] - y->stuff[i] - b; + if (t < 0) { + res->stuff[i] = t + B_BASE; + b = 1; + } else { + res->stuff[i] = t; + b = 0; + } + } + + for (i = y->used; i < x->used; i++) { + t = x->stuff[i] - b; + if (t < 0) { + res->stuff[i] = t + B_BASE; + } else { + res->stuff[i] = t; + b = 0; + } + } + myassert (b == 0); + + res->used = x->used; + u_renormalise(res); + myassert(sane(res)); +} + + +void umul ( B* x, B* y, B* res ) +{ + int i, j, carry; + + myassert(sane(x)); + myassert(sane(y)); + myassert(res->size == maxused_mul(x,y)); + + for (j = 0; j < y->used; j++) res->stuff[j] = 0; + + for (i = 0; i < x->used; i++) { + carry = 0; + for (j = 0; j < y->used; j++) { + carry += res->stuff[i+j] + x->stuff[i]*y->stuff[j]; + res->stuff[i+j] = carry % B_BASE; + carry /= B_BASE; + myassert (carry < B_BASE); + } + res->stuff[i+y->used] = carry; + } + + res->used = x->used+y->used; + u_renormalise(res); + myassert(sane(res)); +} + + +static void uqrm ( B* dend, B* isor, B* dres, B* mres ) +{ + int i, j, t, vh, toolarge, delta, carry, scaleup; + uchar *dend_stuff, *isor_stuff, *tmp; + + myassert(sane(isor)); + myassert(sane(dend)); + myassert(isor->used > 0); // against division by zero + + myassert(dres->size == maxused_qrm(isor,dend)); + myassert(mres->size == maxused_qrm(isor,dend)); + + if (dend->used < isor->used) { + // Result of division must be zero, since dividend has + // fewer digits than the divisor. Remainder is the + // original dividend. + dres->used = 0; + mres->used = dend->used; + for (j = 0; j < mres->used; j++) mres->stuff[j] = dend->stuff[j]; + u_renormalise(dres); u_renormalise(mres); + myassert(sane(dres)); + myassert(sane(mres)); + return; + } + + if (isor->used == 1) { + + // Simple case; divisor is a single digit + carry = 0; + for (j = dend->used-1; j >= 0; j--) { + carry += dend->stuff[j]; + dres->stuff[j] = carry/isor->stuff[0]; + carry = B_BASE*(carry%isor->stuff[0]); + } + carry /= B_BASE; + dres->used = dend->used; + u_renormalise(dres); + + // Remainder is the final carry value + mres->used = 0; + if (carry > 0) { + mres->used = 1; + mres->stuff[0] = carry; + } + u_renormalise(dres); u_renormalise(mres); + myassert(sane(dres)); + myassert(sane(mres)); + return; + + } else { + + // Complex case: both dividend and divisor have two or more digits. + myassert(isor->used >= 2); + myassert(dend->used >= 2); + + // Allocate space for a copy of both dividend and divisor, since we + // need to mess with them. Also allocate tmp as a place to hold + // values of the form quotient_digit * divisor. + dend_stuff = malloc ( sizeof(uchar)*(dend->used+1) ); + isor_stuff = malloc ( sizeof(uchar)*isor->used ); + tmp = malloc ( sizeof(uchar)*(isor->used+1) ); + myassert (dend_stuff && isor_stuff && tmp); + + // Calculate a scaling-up factor, and multiply both divisor and + // dividend by it. Doing this reduces the number of corrections + // needed to the quotient-digit-estimates made in the loop below, + // and thus speeds up division, but is not actually needed to + // get the correct results. The scaleup factor should not increase + // the number of digits needed to represent either the divisor + // (since the factor is derived from it) or the dividend (since + // we already gave it a new leading zero). + scaleup = B_BASE / (1 + isor->stuff[isor->used-1]); + myassert (1 <= scaleup && scaleup <= B_BASE/2); + + if (scaleup == 1) { + // Don't bother to multiply; just copy. + for (j = 0; j < dend->used; j++) dend_stuff[j] = dend->stuff[j]; + for (j = 0; j < isor->used; j++) isor_stuff[j] = isor->stuff[j]; + + // Extend dividend with leading zero. + dend_stuff[dend->used] = tmp[isor->used] = 0; + + } else { + carry = 0; + for (j = 0; j < isor->used; j++) { + t = scaleup * isor->stuff[j] + carry; + isor_stuff[j] = t % B_BASE; + carry = t / B_BASE; + } + myassert (carry == 0); + + carry = 0; + for (j = 0; j < dend->used; j++) { + t = scaleup * dend->stuff[j] + carry; + dend_stuff[j] = t % B_BASE; + carry = t / B_BASE; + } + dend_stuff[dend->used] = carry; + tmp[isor->used] = 0; + } + + // For each quotient digit ... + for (i = dend->used; i >= isor->used; i--) { + myassert (i-2 >= 0); + myassert (i <= dend->used); + myassert (isor->used >= 2); + +#if DEBUG_SAINTEGER_UQRM + printf("\n---------\nqdigit %d\n", i ); + printf("dend_stuff is "); + for (j = dend->used; j>= 0; j--) printf("%d ",dend_stuff[j]); + printf("\n"); +#endif + // Make a guess vh of the quotient digit + vh = (B_BASE*B_BASE*dend_stuff[i] + B_BASE*dend_stuff[i-1] + dend_stuff[i-2]) + / + (B_BASE*isor_stuff[isor->used-1] + isor_stuff[isor->used-2]); + if (vh > B_BASE-1) vh = B_BASE-1; +#if DEBUG_SAINTEGER_UQRM + printf("guess formed from %d %d %d %d %d\n", + dend_stuff[i], dend_stuff[i-1] , dend_stuff[i-2], + isor_stuff[isor->used-1], isor_stuff[isor->used-2]); + printf("guess is %d\n", vh ); +#endif + // Check if vh is too large (by 1). Calculate vh * isor into tmp + // and see if it exceeds the same length prefix of dend. If so, + // vh needs to be decremented. + carry = 0; + for (j = 0; j < isor->used; j++) { + t = vh * isor_stuff[j] + carry; + tmp[j] = t % B_BASE; + carry = t / B_BASE; + } + tmp[isor->used] = carry; + delta = i - isor->used; +#if DEBUG_SAINTEGER_UQRM + printf("final carry is %d\n", carry); + printf("vh * isor is " ); + for (j = isor->used; j >=0; j--) printf("%d ",tmp[j]);printf("\n"); + printf("delta = %d\n", delta ); +#endif + toolarge = 0; + for (j = isor->used; j >= 0; j--) { +#if DEBUG_SAINTEGER_UQRM + printf ( "(%d,%d) ", (int)(tmp[j]), (int)(dend_stuff[j+delta]) ); +#endif + if (tmp[j] > dend_stuff[j+delta]) {toolarge=1; break;}; + if (tmp[j] < dend_stuff[j+delta]) break; + } + + // If we did guess too large, decrement vh and subtract a copy of + // isor from tmp. This had better not go negative! + if (toolarge) { +#if DEBUG_SAINTEGER_UQRM + printf ( "guess too large\n" ); +#endif + vh--; + carry = 0; + for (j = 0; j < isor->used; j++) { + if (carry + isor_stuff[j] > tmp[j]) { + tmp[j] = (B_BASE + tmp[j]) - isor_stuff[j] - carry; + carry = 1; + } else { + tmp[j] = tmp[j] - isor_stuff[j] - carry; + carry = 0; + } + } + //if (carry > 0) {pp(isor);pp(dend);}; + //myassert(carry == 0); + if (carry > 0) { + myassert(tmp[isor->used] > 0); + tmp[isor->used]--; + } +#if DEBUG_SAINTEGER_UQRM + printf("after adjustment of tmp "); + for (j = isor->used; j >=0; j--) printf("%d ",tmp[j]); + printf("\n"); +#endif + } + + // Now vh really is the i'th quotient digit. + // Subtract (tmp << delta) from + // the dividend. + carry = 0; + for (j = 0; j <= isor->used; j++) { + if (carry + tmp[j] > dend_stuff[j+delta]) { + dend_stuff[j+delta] = (B_BASE+dend_stuff[j+delta]) - tmp[j] - carry; + carry = 1; + } else { + dend_stuff[j+delta] = dend_stuff[j+delta] - tmp[j] - carry; + carry = 0; + } + } + myassert(carry==0); + +#if DEBUG_SAINTEGER_UQRM + printf("after final sub "); + for(j=dend->used; j>=0; j--) printf("%d ", dend_stuff[j]); + printf("\n"); +#endif + + // park vh in the result array +#if DEBUG_SAINTEGER_UDIV + printf("[%d] <- %d\n", i-isor->used, vh ); +#endif + dres->stuff[i-isor->used] = vh; + } + } + + // Now we've got all the quotient digits. Zap leading zeroes. + dres->used = dend->used - isor->used + 1; + u_renormalise(dres); + myassert(sane(dres)); + + // The remainder is in dend_stuff. Copy, divide by the original scaling + // factor, and zap leading zeroes. + mres->used = dend->used; + for (j = 0; j < dend->used; j++) mres->stuff[j] = dend_stuff[j]; + u_renormalise(mres); + myassert(sane(mres)); + + if (scaleup > 1) { + carry = 0; + for (j = mres->used-1; j >= 0; j--) { + carry += mres->stuff[j]; + mres->stuff[j] = carry/scaleup; + carry = B_BASE*(carry%scaleup); + } + myassert (carry == 0); + u_renormalise(mres); + myassert(sane(mres)); + } + + free(tmp); + free(isor_stuff); + free(dend_stuff); +} + + +/* -------------------------------------------------------------------------- + * Test framework + * ------------------------------------------------------------------------*/ + +#if 0 +int main ( int argc, char** argv ) +{ + int i, j, t, k, m; + B *bi, *bj, *bk, *bm; + + for (i = -10007; i <= 10007; i++) { + printf ( "i = %d\n", i ); + + t = size_fromInt(); bi = malloc(t); myassert(bi); + do_fromInt(i, t, bi); + + t = do_toInt(bi); myassert(i == t); + + for (j = -10007; j <= 10007; j++) { + + t = size_fromInt(); bj = malloc(t); myassert(bj); + do_fromInt(j, t, bj); + + t = do_toInt(bj); myassert(j == t); + + if (1) { + t = size_add(bi,bj); bk = malloc(t); myassert(bk); + do_add(bi,bj,t,bk); + k = do_toInt(bk); + if (i+j != k) { + pp(bi); pp(bj); pp(bk); + myassert(i+j == k); + } + free(bk); + } + + if (1) { + t = size_sub(bi,bj); bk = malloc(t); myassert(bk); + do_sub(bi,bj,t,bk); + k = do_toInt(bk); + if (i-j != k) { + pp(bi); pp(bj); pp(bk); + myassert(i-j == k); + } + free(bk); + } + + if (1) { + t = size_mul(bi,bj); bk = malloc(t); myassert(bk); + do_mul(bi,bj,t,bk); + k = do_toInt(bk); + if (i*j != k) { + pp(bi); pp(bj); pp(bk); + myassert(i*j == k); + } + free(bk); + } + + if (j != 0) { + t = size_qrm(bi,bj); + bk = malloc(t); myassert(bk); + bm = malloc(t); myassert(bm); + do_qrm(bi,bj,t,bk,bm); + k = do_toInt(bk); + m = do_toInt(bm); + myassert(k == i/j); + myassert(m == i%j); + free(bk); free(bm); + } + + free(bj); + } + free(bi); + + } + printf("done\n"); + return 0; +} +#endif + +#if 0 +int main ( int argc, char** argv ) +{ + B *a, *b, *c, *d, *e; + a = fromInt(1); b=fromInt(9); pp(a); pp(b); + c = mkB( maxused_uqrm(a,b) ); + d = mkB( maxused_uqrm(a,b) ); + e = mkB( maxused_uadd(a,b) ); + uadd(a,b,e); pp(e); + //uqrm(a,b,c,d); pp(c); pp(d); + + return 0; +} +#endif + +/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/sainteger.h b/ghc/interpreter/sainteger.h new file mode 100644 index 0000000..3086a5a --- /dev/null +++ b/ghc/interpreter/sainteger.h @@ -0,0 +1,47 @@ + +#define B_BASE 256 +#define B_BASE_FLT (256.0) + +/* this really ought to be abstract */ +typedef + struct { + int sign; + int size; + int used; + unsigned char stuff[0]; + } + B; + +/* the ops themselves */ +int do_getsign ( B* x ); +int do_cmp ( B* x, B* y ); +void do_add ( B* x, B* y, int sizeRes, B* res ); +void do_sub ( B* x, B* y, int sizeRes, B* res ); +void do_mul ( B* x, B* y, int sizeRes, B* res ); +void do_qrm ( B* x, B* y, int sizeRes, B* qres, B* rres ); +void do_neg ( B* x, int sizeRes, B* res ); + +void do_renormalise ( B* x ); +int is_sane ( B* x ); + +void do_fromInt ( int n, int sizeRes, B* res ); +void do_fromWord ( unsigned int n, int sizeRes, B* res ); +void do_fromStr ( char* str, int sizeRes, B* res ); + +int do_toInt ( B* x ); +unsigned int do_toWord ( B* x ); +float do_toFloat ( B* x ); +double do_toDouble ( B* x ); + +/* the number of bytes needed to hold result of an op */ +int size_add ( B* x, B* y ); +int size_sub ( B* x, B* y ); +int size_mul ( B* x, B* y ); +int size_qrm ( B* x, B* y ); +int size_neg ( B* x ); +int size_fromInt ( void ); +int size_fromWord ( void ); +int size_fromStr ( char* str ); +int size_dblmantissa ( void ); +int size_fltmantissa ( void ); + diff --git a/ghc/interpreter/scc.c b/ghc/interpreter/scc.c index 809d54a..0b418c3 100644 --- a/ghc/interpreter/scc.c +++ b/ghc/interpreter/scc.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: scc.c,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:36 $ + * $Revision: 1.4 $ + * $Date: 1999/04/27 10:07:01 $ * ------------------------------------------------------------------------*/ #ifndef SCC_C @@ -74,20 +74,23 @@ Cell v; { #ifdef SCC static List local SCC(bs) /* sort list with added dependency */ List bs; { /* info into SCCs */ + List tmp = NIL; clearStack(); daSccs = NIL; /* clear current list of SCCs */ for (daCount=1; nonNull(bs); bs=tl(bs)) /* visit each binding */ if (!visited(hd(bs))) LOWLINK(hd(bs)); - - return rev(daSccs); /* reverse to obtain correct order */ + tmp = rev(daSccs); + daSccs = NIL; + return tmp; /* reverse to obtain correct order */ } #endif #ifdef SCC2 /* Two argument version */ static List local SCC2(bs,cs) /* sort lists with added dependency*/ List bs, cs; { /* info into SCCs */ + List tmp = NIL; clearStack(); daSccs = NIL; /* clear current list of SCCs */ @@ -97,8 +100,9 @@ List bs, cs; { /* info into SCCs */ for (; nonNull(cs); cs=tl(cs)) if (!visited(hd(cs))) LOWLINK(hd(cs)); - - return rev(daSccs); /* reverse to obtain correct order */ + tmp = rev(daSccs); + daSccs = NIL; + return tmp; /* reverse to obtain correct order */ } #endif diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index fbf76b5..7b0e601 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: static.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:10 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:07:01 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -25,7 +25,6 @@ * ------------------------------------------------------------------------*/ static Void local kindError Args((Int,Constr,Constr,String,Kind,Int)); -#if !IGNORE_MODULES static Void local checkQualImport Args((Pair)); static Void local checkUnqualImport Args((Triple)); @@ -43,7 +42,6 @@ static Void local importName Args((Module,Name)); static Void local importTycon Args((Module,Tycon)); static Void local importClass Args((Module,Class)); static List local checkExports Args((List)); -#endif static Void local checkTyconDefn Args((Tycon)); static Void local depConstrs Args((Tycon,List,Cell)); @@ -51,11 +49,6 @@ static List local addSels Args((Int,Name,List,List)); static List local selectCtxt Args((List,List)); static Void local checkSynonyms Args((List)); static List local visitSyn Args((List,Tycon,List)); -#if EVAL_INSTANCES -static Void local deriveEval Args((List)); -static List local calcEvalContexts Args((Tycon,List,List)); -static Void local checkBanged Args((Name,Kinds,List,Type)); -#endif static Type local instantiateSyn Args((Type,Type)); static Void local checkClassDefn Args((Class)); @@ -180,13 +173,8 @@ static List local bscc Args((List)); static Void local addRSsigdecls Args((Pair)); static Void local allNoPrevDef Args((Cell)); static Void local noPrevDef Args((Int,Cell)); -#if IGNORE_MODULES -static Void local duplicateErrorAux Args((Int,Text,String)); -#define duplicateError(l,m,t,k) duplicateErrorAux(l,t,k) -#else static Void local duplicateErrorAux Args((Int,Module,Text,String)); #define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k) -#endif static Void local checkTypeIn Args((Pair)); /* -------------------------------------------------------------------------- @@ -265,7 +253,6 @@ Kind extKind; /* Kind of extension, *->row->row */ String reloadModule; #endif -#if !IGNORE_MODULES Void startModule(nm) /* switch to a new module */ Cell nm; { Module m; @@ -377,7 +364,8 @@ Cell entity; { /* Entry from import list */ if (DOTDOT == snd(entity)) { imports=dupOnto(tycon(f).defn,imports); } else { - imports=checkSubentities(imports,snd(entity),tycon(f).defn,"constructor of type",t); + imports=checkSubentities(imports,snd(entity),tycon(f).defn, + "constructor of type",t); } break; default:; @@ -392,7 +380,8 @@ Cell entity; { /* Entry from import list */ if (DOTDOT == snd(entity)) { return dupOnto(cclass(f).members,imports); } else { - return checkSubentities(imports,snd(entity),cclass(f).members,"member of class",t); + return checkSubentities(imports,snd(entity),cclass(f).members, + "member of class",t); } } } @@ -634,14 +623,16 @@ Cell e; { switch (tycon(nm).what) { case SYNONYM: if (DOTDOT!=parts) { - ERRMSG(0) "Explicit constructor list given for type synonym \"%s\" in export list of module \"%s\"", + ERRMSG(0) "Explicit constructor list given for type synonym" + " \"%s\" in export list of module \"%s\"", identToStr(ident), textToStr(mt) EEND; } return cons(pair(nm,DOTDOT),exports); case RESTRICTSYN: - ERRMSG(0) "Transparent export of restricted type synonym \"%s\" in export list of module \"%s\"", + ERRMSG(0) "Transparent export of restricted type synonym" + " \"%s\" in export list of module \"%s\"", identToStr(ident), textToStr(mt) EEND; @@ -692,7 +683,7 @@ List exports; { #endif return es; } -#endif + /* -------------------------------------------------------------------------- * Static analysis of type declarations: @@ -1152,158 +1143,6 @@ List syns; { return removeCell(t,syns); } -#if EVAL_INSTANCES -/* -------------------------------------------------------------------------- - * The following code is used in calculating contexts for the automatically - * derived Eval instances for newtype and restricted type synonyms. This is - * ugly code, resulting from an ugly feature in the language, and I hope that - * the feature, and hence the code, will be removed in the not too distant - * future. - * ------------------------------------------------------------------------*/ - -static Void local deriveEval(tcs) /* Derive instances of Eval */ -List tcs; { - List ts1 = tcs; - List ts = NIL; - for (; nonNull(ts1); ts1=tl(ts1)) { /* Build list of rsyns and newtypes*/ - Tycon t = hd(ts1); /* and derive instances for data */ - switch (whatIs(tycon(t).what)) { - case DATATYPE : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL); - break; - case NEWTYPE : - case RESTRICTSYN : ts = cons(t,ts); - break; - } - } - emptySubstitution(); /* then derive other instances */ - while (nonNull(ts)) { - ts = calcEvalContexts(hd(ts),tl(ts),NIL); - } - emptySubstitution(); - - for (; nonNull(tcs); tcs=tl(tcs)) { /* Check any banged components */ - Tycon t = hd(tcs); - if (whatIs(tycon(t).what)==DATATYPE) { - List cs = tycon(t).defn; - for (; hasCfun(cs); cs=tl(cs)) { - Name c = hd(cs); - if (isPair(name(c).defn)) { - Type t = name(c).type; - List scs = fst(name(c).defn); - Kinds ks = NIL; - List ctxt = NIL; - Int n = 1; - if (isPolyType(t)) { - ks = polySigOf(t); - t = monotypeOf(t); - } - if (whatIs(t)==QUAL) { - ctxt = fst(snd(t)); - t = snd(snd(t)); - } - for (; nonNull(scs); scs=tl(scs)) { - Int i = intOf(hd(scs)); - for (; n=tycon(h).arity) { - expandSyn(h,argCount,&t,&o); - } else if (isOffset(h)) { /* Stop if var at head */ - ctxt = singleton(ap(classEval,copyType(t,o))); - break; - } else if (isTuple(h) /* Check for tuples ... */ - || h==tc /* ... direct recursion */ - || cellIsMember(h,ps) /* ... mutual recursion */ - || tycon(h).what==DATATYPE) {/* ... or datatype. */ - break; /* => empty context */ - } else { - Cell pi = ap(classEval,t); - Inst in; - - if (cellIsMember(h,ts)) { /* Not yet visited? */ - ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts)); - } -<<<<<<<<<<<<<< variant A ->>>>>>>>>>>>>> variant B - -======= end of combination - if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance */ - List qs = inst(in).specifics; - Int o1 = typeOff; - if (isNull(qs)) { /* No context there */ - break; /* => empty context here */ - } - if (isNull(tl(qs)) && classEval==fun(hd(qs))) { - t = arg(hd(qs)); - o = o1; - continue; - } - } - return ts; /* No instance, so give up */ - } - } - addEvalInst(tycon(tc).line,tc,tycon(tc).arity,ctxt); - return ts; -} - -static Void local checkBanged(c,ks,ps,ty) -Name c; /* Check that banged component of c */ -Kinds ks; /* with type ty is an instance of */ -List ps; /* Eval under the predicates in ps. */ -Type ty; { /* (All types using ks) */ - Cell pi = ap(classEval,ty); - if (isNull(provePred(ks,ps,pi))) { - ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN - ERRTEXT "\n*** Constructor : " ETHEN ERREXPR(c); - ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps); - ERRTEXT "\n*** Required : " ETHEN ERRPRED(pi); - ERRTEXT "\n" - EEND; - } -} -#endif - /* -------------------------------------------------------------------------- * Expanding out all type synonyms in a type expression: * ------------------------------------------------------------------------*/ @@ -1543,7 +1382,6 @@ Class c; { /* and other parts of class struct.*/ List ns = NIL; /* List of names */ Int mno; /* Member function number */ - //printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) ); for (mno=0; mno"); + if (isInt(stgVarInfo(v))) { + putStr("("); + putInt(intOf(stgVarInfo(v))); + putStr(")"); + } } } @@ -249,6 +235,10 @@ static Void local putStgAtom( StgAtom a ) putPtr(ptrOf(a)); putChr('#'); break; + case LETREC: case LAMBDA: case CASE: case PRIMCASE: + case STGAPP: case STGPRIM: case STGCON: + putStgExpr(a); + break; default: fprintf(stderr,"\nYoiks: "); printExp(stderr,a); internal("putStgAtom"); @@ -268,49 +258,44 @@ Void putStgAtoms( List as ) putChr('}'); } -Void putStgPat( StgPat pat ) +Void putStgPat( StgCaseAlt alt ) { - putStgVar(pat); - if (nonNull(stgVarBody(pat))) { - StgDiscr d = stgConCon(stgVarBody(pat)); - List vs = stgConArgs(stgVarBody(pat)); - putChr('@'); - switch (whatIs(d)) { - case NAME: - { - unlexVar(name(d).text); - for (; nonNull(vs); vs=tl(vs)) { - putChr(' '); - putStgVar(hd(vs)); - } - break; - } - case TUPLE: - { - putChr('('); - putStgVar(hd(vs)); - vs=tl(vs); - while (nonNull(vs)) { - putChr(','); - putStgVar(hd(vs)); - vs=tl(vs); - } - putChr(')'); - break; - } - default: - fprintf(stderr,"\nYoiks: "); printExp(stderr,d); - internal("putStgPat"); - } - } -} - -Void putStgPrimPat( StgPrimPat pat ) + if (whatIs(alt)==DEEFALT) { + putStgVar(stgDefaultVar(alt)); + } + else + if (whatIs(alt)==CASEALT) { + List vs = stgCaseAltVars(alt); + if (whatIs(stgCaseAltCon(alt))==TUPLE) { + putChr('('); + putStgVar(hd(vs)); + vs=tl(vs); + while (nonNull(vs)) { + putChr(','); + putStgVar(hd(vs)); + vs=tl(vs); + } + putChr(')'); + } + else + if (whatIs(stgCaseAltCon(alt))==NAME) { + unlexVar(name(stgCaseAltCon(alt)).text); + for (; nonNull(vs); vs=tl(vs)) { + putChr(' '); + putStgVar(hd(vs)); + } + } + else + internal("putStgPat(2)"); + } + else + internal("putStgPat(1)"); +} + +Void putStgPrimPat( StgVar v ) { - putStgVar(pat); - if (nonNull(stgVarBody(pat))) { - StgExpr d = stgVarBody(pat); - putChr('@'); + if (nonNull(stgVarBody(v))) { + StgExpr d = stgVarBody(v); switch (whatIs(d)) { case INTCELL: { @@ -322,6 +307,8 @@ Void putStgPrimPat( StgPrimPat pat ) fprintf(stderr,"\nYoiks: "); printExp(stderr,d); internal("putStgPrimPat"); } + } else { + putStgVar(v); } putChr(' '); } @@ -350,23 +337,27 @@ static Void putStgAlts( Int left, List alts ) if (length(alts) == 1) { StgCaseAlt alt = hd(alts); putStr("{ "); - putStgPat(stgCaseAltPat(alt)); + putStgPat(alt); putStr(" ->\n"); pIndent(left); - putStgExpr(stgCaseAltBody(alt)); + if (isDefaultAlt(alt)) + putStgExpr(stgDefaultBody(alt)); else + putStgExpr(stgCaseAltBody(alt)); putStr("}"); } else { putStr("{\n"); for (; nonNull(alts); alts=tl(alts)) { StgCaseAlt alt = hd(alts); pIndent(left+2); - putStgPat(stgCaseAltPat(alt)); + putStgPat(alt); - //putStr(" -> "); putStr(" ->\n"); pIndent(left+4); - putStgExpr(stgCaseAltBody(alt)); + if (isDefaultAlt(alt)) + putStgExpr(stgDefaultBody(alt)); else + putStgExpr(stgCaseAltBody(alt)); + putStr("\n"); } pIndent(left); @@ -379,7 +370,7 @@ static Void putStgPrimAlts( Int left, List alts ) if (length(alts) == 1) { StgPrimAlt alt = hd(alts); putStr("{ "); - mapProc(putStgPrimPat,stgPrimAltPats(alt)); + mapProc(putStgPrimPat,stgPrimAltVars(alt)); putStr(" ->\n"); pIndent(left); putStgExpr(stgPrimAltBody(alt)); @@ -389,7 +380,7 @@ static Void putStgPrimAlts( Int left, List alts ) for (; nonNull(alts); alts=tl(alts)) { StgPrimAlt alt = hd(alts); pIndent(left+2); - mapProc(putStgPrimPat,stgPrimAltPats(alt)); + mapProc(putStgPrimPat,stgPrimAltVars(alt)); putStr(" -> "); putStgExpr(stgPrimAltBody(alt)); putStr("\n"); @@ -401,11 +392,22 @@ static Void putStgPrimAlts( Int left, List alts ) Void putStgExpr( StgExpr e ) /* pretty print expr */ { + if (isNull(e)) putStr("(putStgExpr:NIL)");else + switch (whatIs(e)) { case LETREC: + { + Int left = outColumn; putStgBinds(stgLetBinds(e)); + if (whatIs(stgLetBody(e))==LETREC) { + putStr("\n"); pIndent(left); + } else + if (whatIs(stgLetBody(e))==CASE) { + putStr("\n"); pIndent(left+2); + } putStgExpr(stgLetBody(e)); break; + } case LAMBDA: { Int left = outColumn; @@ -425,6 +427,15 @@ Void putStgExpr( StgExpr e ) /* pretty print expr */ putStgAlts(left,stgCaseAlts(e)); break; } + case DEEFALT: + case CASEALT: + /* a hack; not for regular use */ + putStgAlts(outColumn,singleton(e)); + break; + case PRIMALT: + /* a hack; not for regular use */ + putStgPrimAlts(outColumn,singleton(e)); + break; case PRIMCASE: { Int left = outColumn; @@ -442,18 +453,39 @@ Void putStgExpr( StgExpr e ) /* pretty print expr */ break; } case STGAPP: - putStgVar(stgAppFun(e)); + putStgExpr(stgAppFun(e)); putStgAtoms(stgAppArgs(e)); break; + case STGCON: + putStgRhs(e); + break; case STGVAR: case NAME: putStgVar(e); break; + case CHARCELL: + case INTCELL: + case BIGCELL: + case FLOATCELL: + case STRCELL: + case PTRCELL: + putStgAtom(e); + break; + case AP: + /* hope that it's really a list of StgExprs, so map putStgExpr + over it */ + for (;nonNull(e);e=tl(e)) { + putStgExpr(hd(e)); + putStr("\n"); + } + break; default: - //fprintf(stderr,"\nYoiks: "); printExp(stderr,e); - //internal("putStgExpr"); - //ToDo: rm this appalling hack - fprintf(stderr, " "); putStgAlts(3,e); + internal("putStgExpr"); + /* Pretend it's a list of algebraic case alternatives. Used for + printing the case-alt lists attached to BCOs which are return + continuations. Very useful for debugging. An appalling hack tho. + */ + /* fprintf(stderr, " "); putStgAlts(3,e); */ } } @@ -484,8 +516,8 @@ static void endStgPP( FILE* fp ); static void beginStgPP( FILE* fp ) { outputStream = fp; - //putChr('\n'); outColumn = 0; + fflush(stderr); fflush(stdout); } static void endStgPP( FILE* fp ) @@ -495,10 +527,17 @@ static void endStgPP( FILE* fp ) Void printStg(fp,b) /* Pretty print sc defn on fp */ FILE *fp; -StgVar b; +StgVar b; { + Name n; beginStgPP(fp); - putStgVar(b); + n = nameFromStgVar(b); + if (nonNull(n)) { + if (name(n).inlineMe) { putStr("INLINE\n"); pIndent(0); }; + putStr(textToStr(name(n).text)); + } else { + putStgVar(b); + } putStr(" = "); putStgRhs(stgVarBody(b)); putStr("\n"); @@ -508,56 +547,44 @@ StgVar b; #if 1 /*DEBUG_PRINTER*/ Void ppStg( StgVar v ) { - if ( 1 /*debugCode*/ ) { - printStg(stdout,v); - } + printStg(stdout,v); } Void ppStgExpr( StgExpr e ) { - if ( 1 /*debugCode*/ ) { - beginStgPP(stderr); - putStgExpr(e); - endStgPP(stdout); - } + beginStgPP(stdout); + putStgExpr(e); + endStgPP(stdout); } Void ppStgRhs( StgRhs rhs ) { - if (1 /*debugCode*/ ) { - beginStgPP(stdout); - putStgRhs(rhs); - endStgPP(stdout); - } + beginStgPP(stdout); + putStgRhs(rhs); + endStgPP(stdout); } Void ppStgAlts( List alts ) { - if (1 /*debugCode*/ ) { - beginStgPP(stdout); - putStgAlts(0,alts); - endStgPP(stdout); - } + beginStgPP(stdout); + putStgAlts(0,alts); + endStgPP(stdout); } extern Void ppStgPrimAlts( List alts ) { - if (1 /*debugCode*/ ) { - beginStgPP(stdout); - putStgPrimAlts(0,alts); - endStgPP(stdout); - } + beginStgPP(stdout); + putStgPrimAlts(0,alts); + endStgPP(stdout); } extern Void ppStgVars( List vs ) { - if (1 /*debugCode*/ ) { - beginStgPP(stdout); - printf("Vars: "); - putStgVars(vs); - printf("\n"); - endStgPP(stdout); - } + beginStgPP(stdout); + printf("Vars: "); + putStgVars(vs); + printf("\n"); + endStgPP(stdout); } #endif diff --git a/ghc/interpreter/stgSubst.c b/ghc/interpreter/stgSubst.c index 7b3d978..8d6f34f 100644 --- a/ghc/interpreter/stgSubst.c +++ b/ghc/interpreter/stgSubst.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: stgSubst.c,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:40 $ + * $Revision: 1.4 $ + * $Date: 1999/04/27 10:07:04 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -66,7 +66,9 @@ static Void substBind( List sub, StgVar bind ) static Void substAlt( List sub, StgCaseAlt alt ) { - stgCaseAltBody(alt) = substExpr(sub,stgCaseAltBody(alt)); + if (isDefaultAlt(alt)) + stgDefaultBody(alt) = substExpr(sub,stgDefaultBody(alt)); else + stgCaseAltBody(alt) = substExpr(sub,stgCaseAltBody(alt)); } static Void substPrimAlt( List sub, StgPrimAlt alt ) @@ -99,6 +101,9 @@ StgExpr substExpr( List sub, StgExpr e ) stgAppFun(e) = substVar(sub,stgAppFun(e)); map1Over(substAtom,sub,stgAppArgs(e)); break; + case STGCON: + map1Over(substAtom,sub,stgConArgs(e)); + break; case STGVAR: case NAME: return substVar(sub,e); @@ -108,4 +113,64 @@ StgExpr substExpr( List sub, StgExpr e ) return e; } + +/* A substitution engine more suitable for the optimiser. + Doesn't make so many assumptions about what is an atom. +*/ +StgExpr zubstExpr( List sub, StgExpr e ) +{ + List bs; + switch (whatIs(e)) { + case LETREC: + for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) + stgVarBody(hd(bs)) = zubstExpr(sub,stgVarBody(hd(bs))); + stgLetBody(e) = zubstExpr(sub,stgLetBody(e)); + break; + case LAMBDA: + stgLambdaBody(e) = zubstExpr(sub,stgLambdaBody(e)); + break; + case CASE: + stgCaseScrut(e) = zubstExpr(sub,stgCaseScrut(e)); + map1Proc(zubstExpr,sub,stgCaseAlts(e)); + break; + case PRIMCASE: + stgPrimCaseScrut(e) = zubstExpr(sub,stgPrimCaseScrut(e)); + map1Proc(zubstExpr,sub,stgPrimCaseAlts(e)); + break; + case CASEALT: + stgCaseAltBody(e) = zubstExpr(sub,stgCaseAltBody(e)); + break; + case DEEFALT: + stgDefaultBody(e) = zubstExpr(sub,stgDefaultBody(e)); + break; + case PRIMALT: + stgPrimAltBody(e) = zubstExpr(sub,stgPrimAltBody(e)); + break; + case STGPRIM: + map1Over(zubstExpr,sub,stgPrimArgs(e)); + break; + case STGAPP: + stgAppFun(e) = zubstExpr(sub,stgAppFun(e)); + map1Over(zubstExpr,sub,stgAppArgs(e)); + break; + case STGCON: + map1Over(zubstExpr,sub,stgConArgs(e)); + break; + case STGVAR: + return substVar(sub,e); + case NAME: + case INTCELL: + case STRCELL: + case PTRCELL: + case CHARCELL: + case FLOATCELL: + break; + default: + internal("zubstExpr"); + } + return e; +} + + + /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index b052bc3..7495377 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: storage.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:13 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:07:05 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -27,9 +27,7 @@ static Int local hash Args((String)); static Int local saveText Args((Text)); -#if !IGNORE_MODULES static Module local findQualifier Args((Text)); -#endif static Void local hashTycon Args((Tycon)); static List local insertTycon Args((Tycon,List)); static Void local hashName Args((Name)); @@ -41,17 +39,8 @@ static Cell local markCell Args((Cell)); static Void local markSnd Args((Cell)); static Cell local lowLevelLastIn Args((Cell)); static Cell local lowLevelLastOut Args((Cell)); -/* from STG */ Module local moduleOfScript Args((Script)); Script local scriptThisFile Args((Text)); -/* from 98 */ -#if IO_HANDLES -static Void local freeHandle Args((Int)); -#endif -#if GC_STABLEPTRS -static Void local resetStablePtrs Args((Void)); -#endif -/* end */ /* -------------------------------------------------------------------------- * Text storage: @@ -277,10 +266,8 @@ Text t; { tycon(tyconHw).what = NIL; tycon(tyconHw).conToTag = NIL; tycon(tyconHw).tagToCon = NIL; -#if !IGNORE_MODULES tycon(tyconHw).mod = currentModule; module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); -#endif tycon(tyconHw).nextTyconHash = tyconHash[h]; tyconHash[h] = tyconHw; @@ -301,9 +288,7 @@ Tycon tc; { Tycon oldtc = findTycon(tycon(tc).text); if (isNull(oldtc)) { hashTycon(tc); -#if !IGNORE_MODULES module(currentModule).tycons=cons(tc,module(currentModule).tycons); -#endif return tc; } else return oldtc; @@ -325,9 +310,6 @@ Cell id; { case CONOPCELL : return findTycon(textOf(id)); case QUALIDENT : { -#if IGNORE_MODULES - return findTycon(qtextOf(id)); -#else /* !IGNORE_MODULES */ Text t = qtextOf(id); Module m = findQualifier(qmodOf(id)); List es = NIL; @@ -338,7 +320,6 @@ Cell id; { return fst(e); } return NIL; -#endif /* !IGNORE_MODULES */ } default : internal("findQualTycon2"); } @@ -427,13 +408,16 @@ Cell parent; { name(nameHw).number = EXECNAME; name(nameHw).defn = NIL; name(nameHw).stgVar = NIL; + name(nameHw).stgSize = 0; + name(nameHw).inlineMe = FALSE; + name(nameHw).simplified = FALSE; + name(nameHw).isDBuilder = FALSE; name(nameHw).type = NIL; name(nameHw).primop = 0; name(nameHw).mod = currentModule; module(currentModule).names=cons(nameHw,module(currentModule).names); name(nameHw).nextNameHash = nameHash[h]; nameHash[h] = nameHw; -assert ( name(nameHw).nextNameHash != nameHash[h] ); return nameHw++; } @@ -451,9 +435,7 @@ Name nm; { /* no clash is caused */ Name oldnm = findName(name(nm).text); if (isNull(oldnm)) { hashName(nm); -#if !IGNORE_MODULES module(currentModule).names=cons(nm,module(currentModule).names); -#endif return nm; } else return oldnm; @@ -478,9 +460,6 @@ Cell id; { /* in name table */ case CONOPCELL : return findName(textOf(id)); case QUALIDENT : { -#if IGNORE_MODULES - return findName(qtextOf(id)); -#else /* !IGNORE_MODULES */ Text t = qtextOf(id); Module m = findQualifier(qmodOf(id)); List es = NIL; @@ -506,13 +485,21 @@ Cell id; { /* in name table */ } } return NIL; -#endif /* !IGNORE_MODULES */ } default : internal("findQualName2"); } return 0; /* NOTREACHED */ } + +Name nameFromStgVar ( StgVar v ) +{ + Int n; + for (n = NAMEMIN; n < nameHw; n++) + if (name(n).stgVar == v) return n; + return NIL; +} + /* -------------------------------------------------------------------------- * Primitive functions: * ------------------------------------------------------------------------*/ @@ -694,10 +681,8 @@ Text t; { cclass(classHw).defaults = NIL; cclass(classHw).instances = NIL; classes=cons(classHw,classes); -#if !IGNORE_MODULES cclass(classHw).mod = currentModule; module(currentModule).classes=cons(classHw,module(currentModule).classes); -#endif return classHw++; } @@ -722,9 +707,7 @@ Class c; { /* - if no clash caused */ Class oldc = findClass(cclass(c).text); if (isNull(oldc)) { classes=cons(c,classes); -#if !IGNORE_MODULES module(currentModule).classes=cons(c,module(currentModule).classes); -#endif return c; } else @@ -736,9 +719,6 @@ Cell c; { /* class in class list */ if (!isQualIdent(c)) { return findClass(textOf(c)); } else { -#if IGNORE_MODULES - return findClass(qtextOf(c)); -#else /* !IGNORE_MODULES */ Text t = qtextOf(c); Module m = findQualifier(qmodOf(c)); List es = NIL; @@ -749,7 +729,6 @@ Cell c; { /* class in class list */ if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t) return fst(e); } -#endif } return NIL; } @@ -874,7 +853,6 @@ Void hugsStackOverflow() { /* Report stack overflow */ * * ------------------------------------------------------------------------*/ -#if !IGNORE_MODULES static Module moduleHw; /* next unused Module */ struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */ Module currentModule; /* Module currently being processed*/ @@ -950,7 +928,6 @@ Module m; { classes = module(m).classes; } } -#endif /* !IGNORE_MODULES */ /* -------------------------------------------------------------------------- * Script file storage: @@ -967,9 +944,7 @@ typedef struct { /* record of storage state prior to */ Text textHw; Text nextNewText; Text nextNewDText; -#if !IGNORE_MODULES Module moduleHw; -#endif Tycon tyconHw; Name nameHw; Class classHw; @@ -998,9 +973,7 @@ String f; { /* of status for later restoration */ } #ifdef DEBUG_SHOWUSE showUse("Text", textHw, NUM_TEXT); -#if !IGNORE_MODULES showUse("Module", moduleHw-MODMIN, NUM_MODULE); -#endif showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON); showUse("Name", nameHw-NAMEMIN, NUM_NAME); showUse("Class", classHw-CLASSMIN, NUM_CLASSES); @@ -1009,14 +982,11 @@ String f; { /* of status for later restoration */ showUse("Ext", extHw-EXTMIN, NUM_EXT); #endif #endif - scripts[scriptHw].file = findText( f ? f : "" ); scripts[scriptHw].textHw = textHw; scripts[scriptHw].nextNewText = nextNewText; scripts[scriptHw].nextNewDText = nextNewDText; -#if !IGNORE_MODULES scripts[scriptHw].moduleHw = moduleHw; -#endif scripts[scriptHw].tyconHw = tyconHw; scripts[scriptHw].nameHw = nameHw; scripts[scriptHw].classHw = classHw; @@ -1031,7 +1001,6 @@ Bool isPreludeScript() { /* Test whether this is the Prelude*/ return (scriptHw==0); } -#if !IGNORE_MODULES Bool moduleThisScript(m) /* Test if given module is defined */ Module m; { /* in current script file */ return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw; @@ -1040,7 +1009,6 @@ Module m; { /* in current script file */ Module lastModule() { /* Return module in current script file */ return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude); } -#endif /* !IGNORE_MODULES */ #define scriptThis(nm,t,tag) Script nm(x) \ t x; { \ @@ -1061,7 +1029,6 @@ Script s; { return (s==0) ? modulePrelude : scripts[s-1].moduleHw; } -#if !IGNORE_MODULES String fileOfModule(m) Module m; { Script s; @@ -1075,7 +1042,6 @@ Module m; { } return 0; } -#endif Script scriptThisFile(f) Text f; { @@ -1098,9 +1064,7 @@ Script sno; { /* to reading script sno */ textHw = scripts[sno].textHw; nextNewText = scripts[sno].nextNewText; nextNewDText = scripts[sno].nextNewDText; -#if !IGNORE_MODULES moduleHw = scripts[sno].moduleHw; -#endif tyconHw = scripts[sno].tyconHw; nameHw = scripts[sno].nameHw; classHw = scripts[sno].classHw; @@ -1112,7 +1076,7 @@ Script sno; { /* to reading script sno */ extHw = scripts[sno].extHw; #endif -#if 0 //zzzzzzzzzzzzzzzzz +#if 0 for (i=moduleHw; i >= scripts[sno].moduleHw; --i) { if (module(i).objectFile) { printf("[bogus] closing objectFile for module %d\n",i); @@ -1130,21 +1094,6 @@ Script sno; { /* to reading script sno */ textHash[i][j] = NOTEXT; } -#if IGNORE_MODULES - for (i=0; i=tyconHw) - tc = tycon(tc).nextTyconHash; - tyconHash[i] = tc; - } - - for (i=0; i=nameHw) - n = name(n).nextNameHash; - nameHash[i] = n; - } -#else /* !IGNORE_MODULES */ currentModule=NIL; for (i=0; i0) - fprintf(profile," SYSTEM %d\n",sysCount); -*/ - /* Accumulate costs in top level objects */ - for (i=NAMEMIN; i0) - if (isPair(name(i).parent)) { - Pair p = name(i).parent; - Cell f = fst(p); - fprintf(profile," "); - if (isClass(f)) - fprintf(profile,"%s",textToStr(cclass(f).text)); - else { - fprintf(profile,"%s_",textToStr(cclass(inst(f).c).text)); - /* Will hp2ps accept the spaces produced by this? */ - printPred(profile,inst(f).head); - } - fprintf(profile,"_%s %d\n", - textToStr(name(snd(p)).text), - name(i).count); - } else { - fprintf(profile," %s %d\n", - textToStr(name(i).text), - name(i).count); - } - fprintf(profile,"END_SAMPLE %ld.00\n",numReductions); - } -#endif + everybody(GCDONE); /* can only return if freeList is nonempty on return. */ if (recovered=NUM_HANDLES) { /* If at first we don't */ - garbageCollect(); /* succeed, garbage collect*/ - for (i=0; i=NUM_HANDLES) { /* ... before we give up */ - ERRMSG(0) "Too many handles open; cannot open \"%s\"", s - EEND; - } - else { /* prepare to open file */ - String stmode; - if (binary) { - stmode = (hmode&HAPPEND) ? "ab+" : - (hmode&HWRITE) ? "wb+" : - (hmode&HREAD) ? "rb" : (String)0; - } else { - stmode = (hmode&HAPPEND) ? "a+" : - (hmode&HWRITE) ? "w+" : - (hmode&HREAD) ? "r" : (String)0; - } - if (stmode && (handles[i].hfp=fopen(s,stmode))) { - handles[i].hmode = hmode; - return (handles[i].hcell = ap(HANDCELL,i)); - } - } - return NIL; -} - -static Void local freeHandle(n) /* release handle storage when no */ -Int n; { /* heap references to it remain */ - if (0<=n && nHSTDERR && handles[n].hmode!=HCLOSED && handles[n].hfp) { - fclose(handles[n].hfp); - handles[n].hfp = 0; - } - fst(handles[n].hcell) = snd(handles[n].hcell) = NIL; - handles[n].hcell = NIL; - } -} -#endif - -#if GC_MALLOCPTRS -/* -------------------------------------------------------------------------- - * Malloc Ptrs: - * ------------------------------------------------------------------------*/ - -struct strMallocPtr mallocPtrs[NUM_MALLOCPTRS]; - -/* It might GC (because it uses a table not a list) which will trash any - * unstable pointers. - * (It happens that we never use it with unstable pointers.) - */ -Cell mkMallocPtr(ptr,cleanup) /* create a new malloc pointer */ -Ptr ptr; -Void (*cleanup) Args((Ptr)); { - Int i; - for (i=0; i=NUM_MALLOCPTRS) { /* If at first we don't */ - garbageCollect(); /* succeed, garbage collect*/ - for (i=0; i=NUM_MALLOCPTRS) { /* ... before we give up */ - ERRMSG(0) "Too many ForeignObjs open" - EEND; - } - mallocPtrs[i].ptr = ptr; - mallocPtrs[i].cleanup = cleanup; - mallocPtrs[i].refCount = 1; - return (mallocPtrs[i].mpcell = ap(MPCELL,i)); -} - -Void incMallocPtrRefCnt(n,i) /* change ref count of MallocPtr */ -Int n; -Int i; { - if (!(0<=n && n 0)) - internal("freeMallocPtr"); - mallocPtrs[n].refCount += i; - if (mallocPtrs[n].refCount <= 0) { - mallocPtrs[n].cleanup(mallocPtrs[n].ptr); - - mallocPtrs[n].ptr = 0; - mallocPtrs[n].cleanup = 0; - mallocPtrs[n].refCount = 0; - mallocPtrs[n].mpcell = NIL; - } -} -#endif /* GC_MALLOCPTRS */ - -/* -------------------------------------------------------------------------- - * Stable pointers - * This is a mechanism that allows the C world to manipulate pointers into the - * Haskell heap without having to worry that the garbage collector is going - * to delete it or move it around. - * The implementation and interface is based on my implementation in - * GHC - but, at least for now, is simplified by using a fixed size - * table of stable pointers. - * ------------------------------------------------------------------------*/ - -#if GC_STABLEPTRS - -/* Each entry in the stable pointer table is either a heap pointer - * or is not currently allocated. - * Unallocated entries are threaded together into a freelist. - * The last entry in the list contains the Cell 0; all other values - * contain a Cell whose value is the next free stable ptr in the list. - * It follows that stable pointers are strictly positive (>0). - */ -static Cell stablePtrTable[NUM_STABLEPTRS]; -static Int sptFreeList; -#define SPT(sp) stablePtrTable[(sp)-1] - -static Void local resetStablePtrs() { - Int i; - /* It would be easier to build the free list in the other direction - * but, when debugging, it's way easier to understand if the first - * pointer allocated is "1". - */ - for(i=1; i < NUM_STABLEPTRS; ++i) - SPT(i) = i+1; - SPT(NUM_STABLEPTRS) = 0; - sptFreeList = 1; -} - -Int mkStablePtr(c) /* Create a stable pointer */ -Cell c; { - Int i = sptFreeList; - if (i == 0) - return 0; - sptFreeList = SPT(i); - SPT(i) = c; - return i; -} - -Cell derefStablePtr(p) /* Dereference a stable pointer */ -Int p; { - if (!(1 <= p && p <= NUM_STABLEPTRS)) { - internal("derefStablePtr"); - } - return SPT(p); -} - -Void freeStablePtr(i) /* Free a stable pointer */ -Int i; { - SPT(i) = sptFreeList; - sptFreeList = i; -} - -#undef SPT -#endif /* GC_STABLEPTRS */ /* -------------------------------------------------------------------------- * plugin support @@ -2615,31 +2174,6 @@ Int what; { */ heapTopFst = heapFst + heapSize; heapTopSnd = heapSnd + heapSize; -#if PROFILING - heapTopThd = heapThd + heapSize; - if (profile) { - garbageCollect(); - fclose(profile); -#if HAVE_HP2PS - system("hp2ps profile.hp"); -#endif - profile = 0; - } -#endif -#if IO_HANDLES - handles[HSTDIN].hmode = HREAD; - handles[HSTDOUT].hmode = HAPPEND; - handles[HSTDERR].hmode = HAPPEND; -#endif -#if GC_MALLOCPTRS - for (i=0; i already simplified */ + Bool isDBuilder; /* TRUE => is a dictionary builder */ const void* primop; /* really StgPrim* */ Name nextNameHash; }; @@ -525,6 +510,7 @@ extern Name findQualName Args((Cell)); extern Name addPrimCfun Args((Text,Int,Int,Cell)); extern Name addPrimCfunREP Args((Text,Int,Int,Int)); extern Int sfunPos Args((Name,Name)); +extern Name nameFromStgVar Args((Cell)); /* -------------------------------------------------------------------------- * Type class values: @@ -560,9 +546,7 @@ struct strInst { struct strClass { Text text; /* Name of class */ Int line; /* Line where declaration begins */ -#if !IGNORE_MODULES Module mod; /* module that declares it */ -#endif Int level; /* Level in class hierarchy */ Int arity; /* Number of arguments */ Kinds kinds; /* Kinds of constructors in class */ @@ -598,7 +582,7 @@ extern Inst findNextInst Args((Tycon,Inst)); #define MAXCHARVAL (NUM_CHARS-1) #define isChar(c) (CHARMIN<=(c) && (c) 0) { StgVar vcurr, e1, v, vsi; List args = makeArgs(a); @@ -532,6 +524,8 @@ List scs; { /* in incr order of strict comps. */ StgVar v = mkStgVar(mkStgCon(c,NIL),NIL); name(c).stgVar = v; } + name(c).inlineMe = TRUE; + name(c).stgSize = stgSize(stgVarBody(name(c).stgVar)); stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); } @@ -563,25 +557,15 @@ static Cell foreignResultTy( Type t ) { if (t == typeChar) return mkChar(CHAR_REP); else if (t == typeInt) return mkChar(INT_REP); -#ifdef PROVIDE_INT64 - else if (t == typeInt64) return mkChar(INT64_REP); -#endif -#ifdef PROVIDE_INTEGER else if (t == typeInteger)return mkChar(INTEGER_REP); -#endif -#ifdef PROVIDE_WORD else if (t == typeWord) return mkChar(WORD_REP); -#endif -#ifdef PROVIDE_ADDR else if (t == typeAddr) return mkChar(ADDR_REP); -#endif else if (t == typeFloat) return mkChar(FLOAT_REP); else if (t == typeDouble) return mkChar(DOUBLE_REP); #ifdef PROVIDE_FOREIGN else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */ #endif -#ifdef PROVIDE_ARRAY else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */ else if (whatIs(t) == AP) { @@ -589,7 +573,6 @@ static Cell foreignResultTy( Type t ) if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */ } -#endif /* ToDo: decent line numbers! */ ERRMSG(0) "Illegal foreign type" ETHEN ERRTEXT " \"" ETHEN ERRTYPE(t); @@ -607,27 +590,16 @@ static Name repToBox( char c ) switch (c) { case CHAR_REP: return nameMkC; case INT_REP: return nameMkI; -#ifdef PROVIDE_INT64 - case INT64_REP: return nameMkInt64; -#endif -#ifdef PROVIDE_INTEGER case INTEGER_REP: return nameMkInteger; -#endif -#ifdef PROVIDE_WORD case WORD_REP: return nameMkW; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: return nameMkA; -#endif case FLOAT_REP: return nameMkF; case DOUBLE_REP: return nameMkD; -#ifdef PROVIDE_ARRAY case ARR_REP: return nameMkPrimArray; case BARR_REP: return nameMkPrimByteArray; case REF_REP: return nameMkRef; case MUTARR_REP: return nameMkPrimMutableArray; case MUTBARR_REP: return nameMkPrimMutableByteArray; -#endif #ifdef PROVIDE_STABLE case STABLE_REP: return nameMkStable; #endif @@ -798,7 +770,9 @@ Name n; { const AsmPrim* p = name(n).primop; StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results); StgVar v = mkStgVar(rhs,NIL); - name(n).stgVar = v; + name(n).stgVar = v; + name(n).stgSize = stgSize(stgVarBody(v)); + name(n).inlineMe = TRUE; stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */ } @@ -874,8 +848,10 @@ Void implementForeignImport( Name n ) EEND; } //ppStg(v); - name(n).defn = NIL; - name(n).stgVar = v; + name(n).defn = NIL; + name(n).stgVar = v; + name(n).stgSize = stgSize(stgVarBody(v)); + name(n).inlineMe = TRUE; stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */ } } @@ -885,6 +861,7 @@ Void implementForeignExport( Name n ) internal("implementForeignExport: not implemented"); } +// ToDo: figure out how to set inlineMe for these (non-Name) things Void implementTuple(size) Int size; { if (size > 0) { diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index 1da4c19..d9913e9 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: type.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:16 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:07:09 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -560,9 +560,7 @@ Cell e; { static String aspat = "as (@) pattern"; static String typeSig = "type annotation"; static String lambda = "lambda expression"; - //printf("\n\n+++++++++++++++++++++++++++++++\n"); - //print(e,1000); - //printf("\n\n"); + switch (whatIs(e)) { /* The following cases can occur in either pattern or expr. mode */ @@ -575,16 +573,13 @@ Cell e; { case TUPLE : typeTuple(e); break; -#if BIGNUMS - case POSNUM : - case ZERONUM : - case NEGNUM : { Int alpha = newTyvars(1); - inferType(aVar,alpha); + case BIGCELL : { Int alpha = newTyvars(1); + inferType(aVar,alpha); return ap(ap(nameFromInteger, assumeEvid(predNum,alpha)), e); } -#endif + case INTCELL : { Int alpha = newTyvars(1); inferType(aVar,alpha); return ap(ap(nameFromInt, @@ -1659,7 +1654,7 @@ Class c; { /* defaults for class c */ List locs = NIL; Cell l = mkInt(cclass(c).line); List ps; -//printf("\ntypeClassDefn %s\n", textToStr(cclass(c).text)); + for (ps=params; nonNull(ps); ps=tl(ps)) { Cell v = thd3(hd(ps)); body = ap(body,v); @@ -1673,7 +1668,7 @@ Class c; { /* defaults for class c */ for (; nonNull(mems); mems=tl(mems)) { Cell v = inventVar(); /* Pick a name for component */ Cell imp = NIL; -//printf(" defaulti %s\n", textToStr(name(hd(mems)).text)); + if (nonNull(defs)) { /* Look for default implementation */ imp = hd(defs); defs = tl(defs); @@ -1714,6 +1709,8 @@ Class c; { /* defaults for class c */ body = ap(LETREC,pair(singleton(locs),body)); name(cclass(c).dbuild).defn = singleton(pair(args,body)); + //--------- Default + name(cclass(c).dbuild).inlineMe = TRUE; genDefns = cons(cclass(c).dbuild,genDefns); cclass(c).defaults = NIL; @@ -1725,6 +1722,7 @@ Class c; { /* defaults for class c */ pat = singleton(pat); for (; nonNull(dsels); dsels=tl(dsels)) { name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args)))); + name(hd(dsels)).inlineMe = TRUE; args = tl(args); genDefns = cons(hd(dsels),genDefns); } @@ -1734,7 +1732,6 @@ Class c; { /* defaults for class c */ args = tl(args); genDefns = cons(hd(mems),genDefns); } -//printf("done\n" ); } static Void local typeInstDefn(in) /* Type check implementations of */ @@ -1857,6 +1854,9 @@ Inst in; { /* member functions for instance in*/ name(inst(in).builder).defn /* Register builder imp */ = singleton(pair(args,ap(LETREC,pair(singleton(locs),d)))); + //--------- Actual + name(inst(in).builder).inlineMe = TRUE; + name(inst(in).builder).isDBuilder = TRUE; genDefns = cons(inst(in).builder,genDefns); } @@ -1939,7 +1939,6 @@ Int beta; { tooGeneral(line,mem,rt,t); if (nonNull(preds)) cantEstablish(line,wh,mem,t,ps); -//printf("done\n" ); } /* -------------------------------------------------------------------------- @@ -2411,11 +2410,11 @@ Name s; { /* particular selector, s. */ static Type local basicType Args((Char)); -static Type stateVar = BOGUS(600); //NIL; -static Type alphaVar = BOGUS(601); //NIL; -static Type betaVar = BOGUS(602); //NIL; -static Type gammaVar = BOGUS(603); //NIL; -static Int nextVar = BOGUS(604); //0; +static Type stateVar = NIL; +static Type alphaVar = NIL; +static Type betaVar = NIL; +static Type gammaVar = NIL; +static Int nextVar = 0; static Void clearTyVars( void ) { @@ -2465,33 +2464,21 @@ Char k; { return typeChar; case INT_REP: return typeInt; -#ifdef PROVIDE_INT64 - case INT64_REP: - return typeInt64; -#endif -#ifdef PROVIDE_INTEGER case INTEGER_REP: return typeInteger; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: return typeAddr; -#endif -#ifdef PROVIDE_WORD case WORD_REP: return typeWord; -#endif case FLOAT_REP: return typeFloat; case DOUBLE_REP: return typeDouble; -#ifdef PROVIDE_ARRAY case ARR_REP: return ap(typePrimArray,mkAlphaVar()); case BARR_REP: return typePrimByteArray; case REF_REP: return ap2(typeRef,mkStateVar(),mkAlphaVar()); case MUTARR_REP: return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar()); case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar()); -#endif #ifdef PROVIDE_STABLE case STABLE_REP: return ap(typeStable,mkAlphaVar()); @@ -2633,10 +2620,12 @@ Int what; { case RESET : tcMode = EXPRESSION; preds = NIL; pendingBtyvs = NIL; + daSccs = NIL; emptyAssumption(); break; - case MARK : mark(defnBounds); + case MARK : mark(daSccs); + mark(defnBounds); mark(varsBounds); mark(depends); mark(pendingBtyvs); @@ -2655,17 +2644,12 @@ Int what; { mark(predIntegral); mark(starToStar); mark(predMonad); -#if IO_MONAD - mark(typeProgIO); -#endif break; case INSTALL : typeChecker(RESET); dummyVar = inventVar(); -#if !IGNORE_MODULES setCurrModule(modulePrelude); -#endif starToStar = simpleKind(1); @@ -2694,6 +2678,9 @@ Int what; { fn(aVar, fn(listof, listof)))); + name(nameNil).parent = + name(nameCons).parent = typeList; + name(nameCons).syntax = mkSyntax(RIGHT_ASS,5); @@ -2715,16 +2702,6 @@ Int what; { addPrimCfun(findText("EmptyRow"), 0,0,typeUnit); addPrimCfun(findText("EmptyRec"), 0,0,typeUnit); #endif -#if IO_MONAD - nameUserErr = addPrimCfun(inventText(),1,1,NIL); - nameNameErr = addPrimCfun(inventText(),1,2,NIL); - nameSearchErr= addPrimCfun(inventText(),1,3,NIL); -#if IO_HANDLES - nameIllegal = addPrimCfun(inventText(),0,4,NIL); - nameWriteErr = addPrimCfun(inventText(),1,5,NIL); - nameEOFErr = addPrimCfun(inventText(),1,6,NIL); -#endif -#endif break; } } diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index a034776..d7cb719 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -102,7 +102,17 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) - ,primCompAux + ,trace + -- Arrrggghhh!!! Help! Help! Help! + -- What?! Prelude.hs doesn't even _define_ most of these things! + ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray + ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv + ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open + ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar + ,unsafeInterleaveIO,nh_write,primCharToInt + + -- ToDo: rm -- these are only for debugging + ,primPlusInt,primEqChar,primRunIO ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -696,7 +706,7 @@ instance Integral Int where instance Integral Integer where quotRem = primQuotRemInteger - divMod = primDivModInteger + --divMod = primDivModInteger toInteger = id toInt = primIntegerToInt @@ -738,7 +748,7 @@ numericEnumFrom n = n : (numericEnumFrom $! (n+1)) numericEnumFromThen n m = iterate ((m-n)+) n numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n) numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n') - where p | n' > n = (<= m) + where p | n' >= n = (<= m) | otherwise = (>= m) instance Read Int where @@ -755,6 +765,7 @@ instance Read Integer where instance Show Integer where showsPrec = showSigned showInt + -- Standard Floating types -------------------------------------------------- data Float -- builtin datatype of single precision floating point numbers @@ -922,16 +933,14 @@ instance Read Float where readsPrec p = readSigned readFloat instance Show Float where - showsPrec p = showFloat - --error "should call showFloat" + showsPrec p = showSigned showFloat p instance Read Double where readsPrec p = readSigned readFloat --- Note that showFloat in Numeric isn't used here instance Show Double where - showsPrec p = showFloat - --error "should call showFloat" + showsPrec p = showSigned showFloat p + -- Some standard functions -------------------------------------------------- @@ -1446,11 +1455,20 @@ readInt radix isDig digToInt s = -- showInt is used for positive numbers only showInt :: Integral a => a -> ShowS -showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers" - | otherwise = - let (n',d) = quotRem n 10 - r' = toEnum (fromEnum '0' + fromIntegral d) : r - in if n' == 0 then r' else showInt n' r' +showInt n r + | n < 0 + = error "Numeric.showInt: can't show negative numbers" + | otherwise +{- + = let (n',d) = quotRem n 10 + r' = toEnum (fromEnum '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' +-} + = case quotRem n 10 of { (n',d) -> + let r' = toEnum (fromEnum '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' + } + readSigned:: Real a => ReadS a -> ReadS a readSigned readPos = readParen False read' @@ -1501,9 +1519,6 @@ primPmFlt n x = fromDouble n == x -- ToDo: make the message more informative. primPmFail :: a primPmFail = error "Pattern Match Failure" -primPmFailBUG :: a -primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++ - "**Please** report to v-julsew@microsoft.com. Thx!\n") -- used in desugaring Foreign functions primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a @@ -1555,10 +1570,11 @@ userError :: String -> IOError userError s = primRaise (ErrorCall s) catch :: IO a -> (IOError -> IO a) -> IO a -catch x eh = primCatch x (eh.exception2ioerror) - where - exception2ioerror (IOExcept s) = IOError s - exception2ioerror other = IOError (show other) +catch m k + = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s) + where + e2ioe (IOExcept s) = IOError s + e2ioe other = IOError (show other) putChar :: Char -> IO () putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c) @@ -1597,7 +1613,7 @@ interact f = getContents >>= (putStr . f) readFile :: FilePath -> IO String readFile fname - = fileopen_sendname fname >>= \ptr -> + = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 0 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> @@ -1607,7 +1623,7 @@ readFile fname writeFile :: FilePath -> String -> IO () writeFile fname contents - = fileopen_sendname fname >>= \ptr -> + = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 1 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> @@ -1618,7 +1634,7 @@ writeFile fname contents appendFile :: FilePath -> String -> IO () appendFile fname contents - = fileopen_sendname fname >>= \ptr -> + = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 2 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> @@ -1653,27 +1669,47 @@ instance Show Exception where data IOResult = IOResult deriving (Show) -type FILE_STAR = Int +type FILE_STAR = Int -- FILE * +type Ptr = Int -- char * foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR +foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR +foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int -foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int -foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO () -foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int - -fileopen_sendname :: String -> IO Int -fileopen_sendname fname - = nh_malloc (1 + length fname) >>= \ptr -> - let loop i [] = nh_assign ptr i 0 >> return ptr - loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs +foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr +foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO () +foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO () +foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int + +foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int +foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int +foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr + +copy_String_to_cstring :: String -> IO Ptr +copy_String_to_cstring s + = nh_malloc (1 + length s) >>= \ptr0 -> + let loop ptr [] = nh_store ptr 0 >> return ptr0 + loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") ( + nh_store ptr (primCharToInt c) >> loop (ptr+1) cs + --) in - loop 0 fname + loop ptr0 s + +copy_cstring_to_String :: Ptr -> IO String +copy_cstring_to_String ptr + = nh_load ptr >>= \ci -> + if ci == 0 + then return [] + else copy_cstring_to_String (ptr+1) >>= \cs -> + --trace ("In " ++ show ci) ( + return ((primIntToChar ci) : cs) + --) readfromhandle :: FILE_STAR -> IO String readfromhandle h @@ -1694,6 +1730,31 @@ writetohandle fname h (c:cs) = nh_write h (primCharToInt c) >> writetohandle fname h cs +primGetRawArgs :: IO [String] +primGetRawArgs + = nh_argc >>= \argc -> + accumulate (map (get_one_arg 0) [0 .. argc-1]) + where + get_one_arg :: Int -> Int -> IO String + get_one_arg offset argno + = nh_argvb argno offset >>= \cb -> + if cb == 0 + then return [] + else get_one_arg (offset+1) argno >>= \s -> + return ((primIntToChar cb):s) + +primGetEnv :: String -> IO String +primGetEnv v + = copy_String_to_cstring v >>= \ptr -> + nh_getenv ptr >>= \ptr2 -> + nh_free ptr >> + if ptr2 == 0 + then return [] + else + copy_cstring_to_String ptr2 >>= \result -> + return result + + ------------------------------------------------------------------------------ -- ST, IO -------------------------------------------------------------------- ------------------------------------------------------------------------------ @@ -1704,12 +1765,12 @@ data RealWorld type IO a = ST RealWorld a ---runST :: (forall s. ST s a) -> a -runST :: ST RealWorld a -> a -runST m = fst (unST m theWorld) +--primRunST :: (forall s. ST s a) -> a +primRunST :: ST RealWorld a -> a +primRunST m = fst (unST m theWorld) where theWorld :: RealWorld - theWorld = error "runST: entered the RealWorld" + theWorld = error "primRunST: entered the RealWorld" unST (ST a) = a @@ -1730,11 +1791,11 @@ primRunIO m realWorld = error "panic: Hugs entered the real world" protect :: () -> () protect comp - = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld)) + = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) trace :: String -> a -> a trace s x - = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x unsafeInterleaveST :: ST s a -> ST s a unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) @@ -1744,7 +1805,7 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Addr, ForeignObj, Prim*Array ---------------------------------------------- +-- Word, Addr, ForeignObj, Prim*Array ---------------------------------------- ------------------------------------------------------------------------------ data Addr @@ -1762,9 +1823,22 @@ instance Ord Addr where (>) = primGtAddr -data ForeignObj -makeForeignObj :: Addr -> IO ForeignObj -makeForeignObj = primMakeForeignObj +data Word + +instance Eq Word where + (==) = primEqWord + (/=) = primNeWord + +instance Ord Word where + (<) = primLtWord + (<=) = primLeWord + (>=) = primGeWord + (>) = primGtWord + + +--data ForeignObj +--makeForeignObj :: Addr -> IO ForeignObj +--makeForeignObj = primMakeForeignObj data PrimArray a -- immutable arrays with Int indices @@ -1775,6 +1849,7 @@ data PrimMutableArray s a -- mutable arrays with Int indices data PrimMutableByteArray s + ------------------------------------------------------------------------------ -- hooks to call libHS_cbits ------------------------------------------------- ------------------------------------------------------------------------------ @@ -1971,7 +2046,7 @@ formatRealFloat fmt decs x = s doFmt fmt (is, e) = let ds = map intToDigit is in case fmt of - FFGeneric -> + FFGeneric -> doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) (is, e) FFExponent -> @@ -2060,9 +2135,16 @@ floatToDigits base x = (f*2, b^(-e)*2, 1, 1) k = let k0 = - - 0 - + if b == 2 && base == 10 then + -- logBase 10 2 is slightly bigger than 3/10 so + -- the following will err on the low side. Ignoring + -- the fraction will make it err even more. + -- Haskell promises that p-1 <= logBase b f < p. + (p - 1 + e0) * 3 `div` 10 + else + ceiling ((log (fromInteger (f+1)) + + fromInt e * log (fromInteger b)) / + log (fromInteger base)) fixup n = if n >= 0 then if r + mUp <= expt base n * s then n else fixup (n+1) @@ -2088,6 +2170,23 @@ floatToDigits base x = in gen [] (r * bk) s (mUp * bk) (mDn * bk) in (map toInt (reverse rds), k) +{- -- Exponentiation with(out) a cache for the most common numbers. expt :: Integer -> Int -> Integer expt base n = base^n +-} + + +-- Exponentiation with a cache for the most common numbers. +minExpt = 0::Int +maxExpt = 1100::Int +expt :: Integer -> Int -> Integer +expt base n = + if base == 2 && n >= minExpt && n <= maxExpt then + expts !! (n-minExpt) + else + base^n + +expts :: [Integer] +expts = [2^n | n <- [minExpt .. maxExpt]] + diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index a9c5fa1..c959e3f 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/03/09 14:51:19 $ + * $Revision: 1.8 $ + * $Date: 1999/04/27 10:07:15 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -76,15 +76,6 @@ typedef struct { * Queues (of instructions, ptrs, nonptrs) * ------------------------------------------------------------------------*/ -/* ToDo: while debugging, we use a chunk size of 1 to stress-test the code - * this should be fine-tuned using statistics on common sizes - */ - -#define InstrsChunkSize 40 -#define PtrsChunkSize 10 -#define RefsChunkSize 10 -#define NonPtrsChunkSize 10 - #define Queue Instrs #define Type StgWord8 #include "QueueTemplate.h" @@ -146,15 +137,17 @@ struct AsmCAF_ { struct AsmBCO_ { struct AsmObject_ object; /* must be first in struct */ - int /*StgExpr*/ stgexpr; Instrs is; NonPtrs nps; + int /*StgExpr*/ stgexpr; + /* abstract machine ("executed" during compilation) */ AsmSp sp; /* stack ptr */ AsmSp max_sp; StgWord hp; /* heap ptr */ StgWord max_hp; + Instr lastOpc; }; static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference ) @@ -199,13 +192,6 @@ static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference ) barf("asmResolveRef"); } obj->num_unresolved -= 1; - - if (obj->num_unresolved == 0) { - /* todo: free the queues */ - - /* we don't print until all ptrs are resolved */ - IF_DEBUG(codegen,printObj(obj->closure);printf("\n\n")); - } } static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i ) @@ -237,19 +223,13 @@ static void asmEndObject( AsmObject obj, StgClosure* c ) obj->closure = c; mapQueue(Ptrs, AsmObject, obj->ptrs, asmAddRef(x,obj,i)); mapQueue(Refs, AsmRef, obj->refs, asmResolveRef(x.ref,x.i,c)); -#if 0 + if (obj->num_unresolved == 0) { - /* todo: free the queues */ + freePtrs(&obj->ptrs); + freeRefs(&obj->refs); /* we don't print until all ptrs are resolved */ - IF_DEBUG(codegen, - if (obj->num_unresolved > 0) - fprintf(stderr, "{{%d unresolved}} ", obj->num_unresolved); - ) IF_DEBUG(codegen,printObj(obj->closure)); } - //printf( "unresolved %d\n", obj->num_unresolved); - //printObj(obj->closure); -#endif } int asmObjectHasClosure ( AsmObject obj ) @@ -364,6 +344,7 @@ void asmEndCAF( AsmCAF caf, AsmBCO body ) o->body = NULL; o->value = stgCast(StgClosure*,0xdeadbeef); o->link = stgCast(StgCAF*,0xdeadbeef); + o->mut_link = NULL; asmAddPtr(&caf->object,&body->object); asmEndObject(&caf->object,c); } @@ -381,6 +362,7 @@ AsmBCO asmBeginBCO( int /*StgExpr*/ e ) bco->stgexpr = e; bco->max_sp = bco->sp = 0; bco->max_hp = bco->hp = 0; + bco->lastOpc = i_INTERNAL_ERROR; return bco; } @@ -388,11 +370,7 @@ void asmEndBCO( AsmBCO bco ) { nat p = bco->object.ptrs.len; nat np = bco->nps.len; -#if 0 - nat is = bco->is.len + 4; /* 4 for stack and heap checks */ -#else - nat is = bco->is.len + 2; /* 4 for stack check */ -#endif + nat is = bco->is.len + 2; /* 2 for stack check */ StgClosure* c = asmAlloc(BCO_sizeW(p,np,is)); StgBCO* o = stgCast(StgBCO*,c); @@ -409,13 +387,11 @@ void asmEndBCO( AsmBCO bco ) bco->max_hp = stg_max(bco->hp,bco->max_hp); bcoInstr(o,j++) = i_STK_CHECK; bcoInstr(o,j++) = bco->max_sp; -#if 0 - bcoInstr(o,j++) = i_HP_CHECK; - bcoInstr(o,j++) = bco->max_hp; -#endif mapQueue(Instrs, StgWord8, bco->is, bcoInstr(o,j++) = x); ASSERT(j == is); } + freeInstrs(&bco->is); + freeNonPtrs(&bco->nps); asmEndObject(&bco->object,c); } @@ -423,25 +399,39 @@ void asmEndBCO( AsmBCO bco ) * * ------------------------------------------------------------------------*/ +static void asmInstrOp ( AsmBCO bco, StgWord i ) +{ + ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */ + bco->lastOpc = i; + insertInstrs(&(bco->is),i); +} + static void asmInstr8 ( AsmBCO bco, StgWord i ) { - if (i >= 256) { - fprintf(stderr, "too big (256)\n"); - } + if (i >= 256) { ASSERT(i < 256); /* must be a byte */ + } insertInstrs(&(bco->is),i); } static void asmInstr16 ( AsmBCO bco, StgWord i ) { - if (i >= 65536) { - fprintf(stderr, "too big (65536)\n"); - } - ASSERT(i < 65536); /* must be a byte */ + ASSERT(i < 65536); /* must be a short */ insertInstrs(&(bco->is),i / 256); insertInstrs(&(bco->is),i % 256); } +static Instr asmInstrBack ( AsmBCO bco, StgWord n ) +{ + return bco->is.elems[bco->is.len - n]; +} + +static void asmInstrRecede ( AsmBCO bco, StgWord n ) +{ + if (bco->is.len < n) barf("asmInstrRecede"); + bco->is.len -= n; +} + static void asmPtr( AsmBCO bco, AsmObject x ) { insertPtrs( &bco->object.ptrs, x ); @@ -470,24 +460,15 @@ static StgWord repSizeW( AsmRep rep ) case BOOL_REP: case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt); -#ifdef PROVIDE_INT64 - case INT64_REP: return sizeofW(StgWord) + sizeofW(StgInt64); -#endif -#ifdef PROVIDE_WORD case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord); -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr); -#endif case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat); case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble); #ifdef PROVIDE_STABLE case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord); #endif -#ifdef PROVIDE_INTEGER case INTEGER_REP: -#endif #ifdef PROVIDE_WEAK case WEAK_REP: #endif @@ -499,13 +480,11 @@ static StgWord repSizeW( AsmRep rep ) case GAMMA_REP: /* c */ case HANDLER_REP: /* IOError -> IO a */ case ERROR_REP: /* IOError */ -#ifdef PROVIDE_ARRAY case ARR_REP : /* PrimArray a */ case BARR_REP : /* PrimByteArray a */ case REF_REP : /* Ref s a */ case MUTARR_REP : /* PrimMutableArray s a */ case MUTBARR_REP: /* PrimMutableByteArray s a */ -#endif #ifdef PROVIDE_CONCURRENT case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ @@ -517,228 +496,242 @@ static StgWord repSizeW( AsmRep rep ) } } + +int asmRepSizeW ( AsmRep rep ) +{ + return repSizeW ( rep ); +} + + /* -------------------------------------------------------------------------- - * Instruction emission + * Instruction emission. All instructions should be routed through here + * so that the peephole optimiser gets to see what's happening. * ------------------------------------------------------------------------*/ -static void emit_i0 ( AsmBCO bco, Instr opcode ) +static void emiti_ ( AsmBCO bco, Instr opcode ) { - asmInstr8(bco,opcode); + StgInt x, y; + if (bco->lastOpc == i_SLIDE && opcode == i_ENTER) { + /* SLIDE x y ; ENTER ===> SE x y */ + x = asmInstrBack(bco,2); + y = asmInstrBack(bco,1); + asmInstrRecede(bco,3); + asmInstrOp(bco,i_SE); asmInstr8(bco,x); asmInstr8(bco,y); + } + else + if (bco->lastOpc == i_RV && opcode == i_ENTER) { + /* RV x y ; ENTER ===> RVE x (y-2) + Because RETADDR pushes 2 words on the stack, y must be at least 2. */ + x = asmInstrBack(bco,2); + y = asmInstrBack(bco,1); + if (y < 2) barf("emiti_: RVE: impossible y value"); + asmInstrRecede(bco,3); + asmInstrOp(bco, i_RVE); asmInstr8(bco,x); asmInstr8(bco,y-2); + } + else { + asmInstrOp(bco,opcode); + } +} + +static void emiti_8 ( AsmBCO bco, Instr opcode, int arg1 ) +{ + StgInt x; + if (bco->lastOpc == i_VAR && opcode == i_VAR) { + /* VAR x ; VAR y ===> VV x y */ + x = asmInstrBack(bco,1); + asmInstrRecede(bco,2); + asmInstrOp(bco,i_VV); asmInstr8(bco,x); asmInstr8(bco,arg1); + } + else + if (bco->lastOpc == i_RETADDR && opcode == i_VAR) { + /* RETADDR x ; VAR y ===> RV x y */ + x = asmInstrBack(bco,1); + asmInstrRecede(bco,2); + asmInstrOp(bco, i_RV); asmInstr8(bco,x); asmInstr8(bco,arg1); + } + else { + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); + } } -static void emit_i1 ( AsmBCO bco, Instr opcode, int arg1 ) +static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 ) { - asmInstr8(bco,opcode); - asmInstr8(bco,arg1); + asmInstrOp(bco,opcode); + asmInstr16(bco,arg1); } -static void emit_i2 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +static void emiti_8_8 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) { - asmInstr8(bco,opcode); + asmInstrOp(bco,opcode); asmInstr8(bco,arg1); asmInstr8(bco,arg2); } +static void emiti_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +{ + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); + asmInstr16(bco,arg2); +} + +static void emiti_16_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +{ + asmInstrOp(bco,opcode); + asmInstr16(bco,arg1); + asmInstr16(bco,arg2); +} + + +/* -------------------------------------------------------------------------- + * Wrappers around the above fns + * ------------------------------------------------------------------------*/ + static void emit_i_VAR_INT ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_VAR_INT); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_VAR_INT_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_VAR_INT, arg1); else + emiti_16(bco,i_VAR_INT_big,arg1); +} + +static void emit_i_VAR_WORD ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_WORD, arg1); else + emiti_16(bco,i_VAR_WORD_big,arg1); } -#ifdef PROVIDE_ADDR static void emit_i_VAR_ADDR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_VAR_ADDR); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_VAR_ADDR_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_VAR_ADDR, arg1); else + emiti_16(bco,i_VAR_ADDR_big,arg1); } -#endif static void emit_i_VAR_CHAR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_VAR_CHAR); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_VAR_CHAR_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_VAR_CHAR, arg1); else + emiti_16(bco,i_VAR_CHAR_big,arg1); } static void emit_i_VAR_FLOAT ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_VAR_FLOAT); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_VAR_FLOAT_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_VAR_FLOAT, arg1); else + emiti_16(bco,i_VAR_FLOAT_big,arg1); } static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_VAR_DOUBLE); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_VAR_DOUBLE_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_VAR_DOUBLE, arg1); else + emiti_16(bco,i_VAR_DOUBLE_big,arg1); } static void emit_i_VAR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_VAR); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_VAR_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_VAR, arg1); else + emiti_16(bco,i_VAR_big,arg1); +} + +static void emit_i_PACK ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_PACK, arg1); else + emiti_16(bco,i_PACK_big,arg1); } static void emit_i_SLIDE ( AsmBCO bco, int arg1, int arg2 ) { ASSERT(arg1 >= 0); ASSERT(arg2 >= 0); - if (arg1 < 256 && arg2 < 256) { - asmInstr8(bco,i_SLIDE); - asmInstr8(bco,arg1); - asmInstr8(bco,arg2); - } else { - asmInstr8(bco,i_SLIDE_big); - asmInstr16(bco,arg1); - asmInstr16(bco,arg2); - } + if (arg1 < 256 && arg2 < 256) + emiti_8_8 (bco,i_SLIDE, arg1,arg2); else + emiti_16_16(bco,i_SLIDE_big,arg1,arg2); } static void emit_i_MKAP ( AsmBCO bco, int arg1, int arg2 ) { ASSERT(arg1 >= 0); ASSERT(arg2 >= 0); - if (arg1 < 256 && arg2 < 256) { - asmInstr8(bco,i_MKAP); - asmInstr8(bco,arg1); - asmInstr8(bco,arg2); - } else { - asmInstr8(bco,i_MKAP_big); - asmInstr16(bco,arg1); - asmInstr16(bco,arg2); - } + if (arg1 < 256 && arg2 < 256) + emiti_8_8 (bco,i_MKAP, arg1,arg2); else + emiti_16_16(bco,i_MKAP_big,arg1,arg2); } + static void emit_i_CONST_INT ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST_INT); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_INT_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST_INT, arg1); else + emiti_16(bco,i_CONST_INT_big,arg1); } -#ifdef PROVIDE_INTEGER static void emit_i_CONST_INTEGER ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST_INTEGER); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_INTEGER_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST_INTEGER, arg1); else + emiti_16(bco,i_CONST_INTEGER_big,arg1); } -#endif static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST_ADDR); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_ADDR_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST_ADDR, arg1); else + emiti_16(bco,i_CONST_ADDR_big,arg1); } static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST_CHAR); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_CHAR_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST_CHAR, arg1); else + emiti_16(bco,i_CONST_CHAR_big,arg1); } static void emit_i_CONST_FLOAT ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST_FLOAT); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_FLOAT_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST_FLOAT, arg1); else + emiti_16(bco,i_CONST_FLOAT_big,arg1); } static void emit_i_CONST_DOUBLE ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST_DOUBLE); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_DOUBLE_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST_DOUBLE, arg1); else + emiti_16(bco,i_CONST_DOUBLE_big,arg1); } -static void emit_i_RETADDR ( AsmBCO bco, int arg1 ) +static void emit_i_CONST ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_RETADDR); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_RETADDR_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_CONST, arg1); else + emiti_16(bco,i_CONST_big,arg1); } -static void emit_i_CONST ( AsmBCO bco, int arg1 ) +static void emit_i_RETADDR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); - if (arg1 < 256) { - asmInstr8(bco,i_CONST); - asmInstr8(bco,arg1); - } else { - asmInstr8(bco,i_CONST_big); - asmInstr16(bco,arg1); - } + if (arg1 < 256) + emiti_8 (bco,i_RETADDR, arg1); else + emiti_16(bco,i_RETADDR_big,arg1); } @@ -756,7 +749,7 @@ void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg ) { nat args = bco->sp - last_arg; if (args != 0) { /* optimisation */ - emit_i1(bco,i_ARG_CHECK,args); + emiti_8(bco,i_ARG_CHECK,args); grabHpNonUpd(bco,PAP_sizeW(args-1)); resetHp(bco,0); } @@ -777,7 +770,7 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) int offset; if (rep == VOID_REP) { - emit_i0(bco,i_VOID); + emiti_(bco,i_VOID); bco->sp += repSizeW(rep); return; } @@ -788,21 +781,12 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case INT_REP: emit_i_VAR_INT(bco,offset); break; -#ifdef PROVIDE_INT64 - case INT64_REP: - emit_i_VAR_INT64(bco,offset); - break; -#endif -#ifdef PROVIDE_WORD case WORD_REP: emit_i_VAR_WORD(bco,offset); break; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: emit_i_VAR_ADDR(bco,offset); break; -#endif case CHAR_REP: emit_i_VAR_CHAR(bco,offset); break; @@ -818,9 +802,7 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) break; #endif -#ifdef PROVIDE_INTEGER case INTEGER_REP: -#endif #ifdef PROVIDE_WEAK case WEAK_REP: #endif @@ -832,13 +814,11 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case GAMMA_REP: /* c */ case HANDLER_REP: /* IOError -> IO a */ case ERROR_REP: /* IOError */ -#ifdef PROVIDE_ARRAY case ARR_REP : /* PrimArray a */ case BARR_REP : /* PrimByteArray a */ case REF_REP : /* Ref s a */ case MUTARR_REP : /* PrimMutableArray s a */ case MUTBARR_REP: /* PrimMutableByteArray s a */ -#endif #ifdef PROVIDE_CONCURRENT case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ @@ -870,7 +850,7 @@ void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 ) emit_i_SLIDE(bco,x,y); bco->sp -= sp1 - sp2; } - emit_i0(bco,i_ENTER); + emiti_(bco,i_ENTER); } /* -------------------------------------------------------------------------- @@ -881,42 +861,32 @@ AsmVar asmBox( AsmBCO bco, AsmRep rep ) { switch (rep) { case CHAR_REP: - emit_i0(bco,i_PACK_CHAR); + emiti_(bco,i_PACK_CHAR); grabHpNonUpd(bco,Czh_sizeW); break; case INT_REP: - emit_i0(bco,i_PACK_INT); + emiti_(bco,i_PACK_INT); grabHpNonUpd(bco,Izh_sizeW); break; -#ifdef PROVIDE_INT64 - case INT64_REP: - emit_i0(bco,i_PACK_INT64); - grabHpNonUpd(bco,I64zh_sizeW); - break; -#endif -#ifdef PROVIDE_WORD case WORD_REP: - emit_i0(bco,i_PACK_WORD); + emiti_(bco,i_PACK_WORD); grabHpNonUpd(bco,Wzh_sizeW); break; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: - emit_i0(bco,i_PACK_ADDR); + emiti_(bco,i_PACK_ADDR); grabHpNonUpd(bco,Azh_sizeW); break; -#endif case FLOAT_REP: - emit_i0(bco,i_PACK_FLOAT); + emiti_(bco,i_PACK_FLOAT); grabHpNonUpd(bco,Fzh_sizeW); break; case DOUBLE_REP: - emit_i0(bco,i_PACK_DOUBLE); + emiti_(bco,i_PACK_DOUBLE); grabHpNonUpd(bco,Dzh_sizeW); break; #ifdef PROVIDE_STABLE case STABLE_REP: - emit_i0(bco,i_PACK_STABLE); + emiti_(bco,i_PACK_STABLE); grabHpNonUpd(bco,Stablezh_sizeW); break; #endif @@ -938,35 +908,26 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) { switch (rep) { case INT_REP: - emit_i0(bco,i_UNPACK_INT); + emiti_(bco,i_UNPACK_INT); break; -#ifdef PROVIDE_INT64 - case INT64_REP: - emit_i0(bco,i_UNPACK_INT64); - break; -#endif -#ifdef PROVIDE_WORD case WORD_REP: - emit_i0(bco,i_UNPACK_WORD); + emiti_(bco,i_UNPACK_WORD); break; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: - emit_i0(bco,i_UNPACK_ADDR); + emiti_(bco,i_UNPACK_ADDR); break; -#endif case CHAR_REP: - emit_i0(bco,i_UNPACK_CHAR); + emiti_(bco,i_UNPACK_CHAR); break; case FLOAT_REP: - emit_i0(bco,i_UNPACK_FLOAT); + emiti_(bco,i_UNPACK_FLOAT); break; case DOUBLE_REP: - emit_i0(bco,i_UNPACK_DOUBLE); + emiti_(bco,i_UNPACK_DOUBLE); break; #ifdef PROVIDE_STABLE case STABLE_REP: - emit_i0(bco,i_UNPACK_STABLE); + emiti_(bco,i_UNPACK_STABLE); break; #endif default: @@ -977,71 +938,6 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) return bco->sp; } -/* -------------------------------------------------------------------------- - * Return unboxed Ints, Floats, etc - * ------------------------------------------------------------------------*/ - -void asmReturnUnboxed( AsmBCO bco, AsmRep rep ) -{ - switch (rep) { - case CHAR_REP: - emit_i0(bco,i_RETURN_CHAR); - break; - case INT_REP: - emit_i0(bco,i_RETURN_INT); - break; -#ifdef PROVIDE_INT64 - case INT64_REP: - emit_i0(bco,i_RETURN_INT64); - break; -#endif -#ifdef PROVIDE_WORD - case WORD_REP: - emit_i0(bco,i_RETURN_WORD); - break; -#endif -#ifdef PROVIDE_ADDR - case ADDR_REP: - emit_i0(bco,i_RETURN_ADDR); - break; -#endif - case FLOAT_REP: - emit_i0(bco,i_RETURN_FLOAT); - break; - case DOUBLE_REP: - emit_i0(bco,i_RETURN_DOUBLE); - break; -#ifdef PROVIDE_STABLE - case STABLE_REP: - emit_i0(bco,i_RETURN_STABLE); - break; -#endif -#ifdef PROVIDE_INTEGER - case INTEGER_REP: -#endif -#ifdef PROVIDE_WEAK - case WEAK_REP: -#endif -#ifdef PROVIDE_FOREIGN - case FOREIGN_REP: -#endif -#ifdef PROVIDE_ARRAY - case ARR_REP : /* PrimArray a */ - case BARR_REP : /* PrimByteArray a */ - case REF_REP : /* Ref s a */ - case MUTARR_REP : /* PrimMutableArray s a */ - case MUTBARR_REP: /* PrimMutableByteArray s a */ -#endif -#ifdef PROVIDE_CONCURRENT - case THREADID_REP: /* ThreadId */ - case MVAR_REP: /* MVar a */ -#endif - emit_i0(bco,i_RETURN_GENERIC); - break; - default: - barf("asmReturnUnboxed %d",rep); - } -} /* -------------------------------------------------------------------------- * Push unboxed Ints, Floats, etc @@ -1054,41 +950,26 @@ void asmConstInt( AsmBCO bco, AsmInt x ) bco->sp += repSizeW(INT_REP); } -#ifdef PROVIDE_INT64 -void asmConstInt64( AsmBCO bco, AsmInt64 x ) -{ - emit_i_CONST_INT64(bco,bco->nps.len); - asmWords(bco,AsmInt64,x); - bco->sp += repSizeW(INT64_REP); -} -#endif - -#ifdef PROVIDE_INTEGER void asmConstInteger( AsmBCO bco, AsmString x ) { emit_i_CONST_INTEGER(bco,bco->nps.len); asmWords(bco,AsmString,x); bco->sp += repSizeW(INTEGER_REP); } -#endif -#ifdef PROVIDE_ADDR void asmConstAddr( AsmBCO bco, AsmAddr x ) { emit_i_CONST_ADDR(bco,bco->nps.len); asmWords(bco,AsmAddr,x); bco->sp += repSizeW(ADDR_REP); } -#endif -#ifdef PROVIDE_WORD void asmConstWord( AsmBCO bco, AsmWord x ) { - emit_i_CONST_INT(bco->nps.len); - asmWords(bco,AsmWord,x); + emit_i_CONST_INT(bco,bco->nps.len); + asmWords(bco,AsmWord,(AsmInt)x); bco->sp += repSizeW(WORD_REP); } -#endif void asmConstChar( AsmBCO bco, AsmChar x ) { @@ -1157,20 +1038,12 @@ AsmSp asmBeginAlt( AsmBCO bco ) void asmEndAlt( AsmBCO bco, AsmSp sp ) { -#if 0 - /* This warning is now redundant since we no longer use the hp/max_hp - * information calculated by the assembler - */ -#warning ToDo: adjust hp/max_hp in asmEndAlt -#endif resetSp(bco,sp); } AsmPc asmTest( AsmBCO bco, AsmWord tag ) { - asmInstr8(bco,i_TEST); - asmInstr8(bco,tag); - asmInstr16(bco,0); + emiti_8_16(bco,i_TEST,tag,0); return bco->is.len; } @@ -1178,8 +1051,7 @@ AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x ) { asmVar(bco,v,INT_REP); asmConstInt(bco,x); - asmInstr8(bco,i_TEST_INT); - asmInstr16(bco,0); + emiti_16(bco,i_TEST_INT,0); bco->sp -= 2*repSizeW(INT_REP); return bco->is.len; } @@ -1195,7 +1067,7 @@ void asmFixBranch( AsmBCO bco, AsmPc from ) void asmPanic( AsmBCO bco ) { - emit_i0(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */ + emiti_(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */ } /* -------------------------------------------------------------------------- @@ -1209,7 +1081,7 @@ AsmSp asmBeginPrim( AsmBCO bco ) void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base ) { - emit_i1(bco,prim->prefix,prim->opcode); + emiti_8(bco,prim->prefix,prim->opcode); bco->sp = base; } @@ -1255,45 +1127,6 @@ const AsmPrim asmPrimOps[] = { , { "primShiftRAInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt } , { "primShiftRLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt } -#ifdef PROVIDE_INT64 - /* Int64# operations */ - , { "primGtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_gtInt64 } - , { "primGeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_geInt64 } - , { "primEqInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_eqInt64 } - , { "primNeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_neInt64 } - , { "primLtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_ltInt64 } - , { "primLeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_leInt64 } - , { "primMinInt64", "", "z", MONAD_Id, i_PRIMOP1, i_minInt64 } - , { "primMaxInt64", "", "z", MONAD_Id, i_PRIMOP1, i_maxInt64 } - , { "primPlusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_plusInt64 } - , { "primMinusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_minusInt64 } - , { "primTimesInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_timesInt64 } - , { "primQuotInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_quotInt64 } - , { "primRemInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_remInt64 } - , { "primQuotRemInt64", "zz", "zz", MONAD_Id, i_PRIMOP1, i_quotRemInt64 } - , { "primNegateInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_negateInt64 } - - , { "primAndInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_andInt64 } - , { "primOrInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_orInt64 } - , { "primXorInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_xorInt64 } - , { "primNotInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_notInt64 } - , { "primShiftLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftLInt64 } - , { "primShiftRAInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRAInt64 } - , { "primShiftRLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRLInt64 } - - , { "primInt64ToInt", "z", "I", MONAD_Id, i_PRIMOP1, i_int64ToInt } - , { "primIntToInt64", "I", "z", MONAD_Id, i_PRIMOP1, i_intToInt64 } -#ifdef PROVIDE_WORD - , { "primInt64ToWord", "z", "W", MONAD_Id, i_PRIMOP1, i_int64ToWord } - , { "primWordToInt64", "W", "z", MONAD_Id, i_PRIMOP1, i_wordToInt64 } -#endif - , { "primInt64ToFloat", "z", "F", MONAD_Id, i_PRIMOP1, i_int64ToFloat } - , { "primFloatToInt64", "F", "z", MONAD_Id, i_PRIMOP1, i_floatToInt64 } - , { "primInt64ToDouble", "z", "D", MONAD_Id, i_PRIMOP1, i_int64ToDouble } - , { "primDoubleToInt64", "D", "z", MONAD_Id, i_PRIMOP1, i_doubleToInt64 } -#endif - -#ifdef PROVIDE_WORD /* Word# operations */ , { "primGtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_gtWord } , { "primGeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_geWord } @@ -1321,9 +1154,7 @@ const AsmPrim asmPrimOps[] = { , { "primIntToWord", "I", "W", MONAD_Id, i_PRIMOP1, i_intToWord } , { "primWordToInt", "W", "I", MONAD_Id, i_PRIMOP1, i_wordToInt } -#endif -#ifdef PROVIDE_ADDR /* Addr# operations */ , { "primGtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_gtAddr } , { "primGeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_geAddr } @@ -1336,12 +1167,7 @@ const AsmPrim asmPrimOps[] = { , { "primIndexCharOffAddr", "AI", "C", MONAD_Id, i_PRIMOP1, i_indexCharOffAddr } , { "primIndexIntOffAddr", "AI", "I", MONAD_Id, i_PRIMOP1, i_indexIntOffAddr } -#ifdef PROVIDE_INT64 - , { "primIndexInt64OffAddr", "AI", "z", MONAD_Id, i_PRIMOP1, i_indexInt64OffAddr } -#endif -#ifdef PROVIDE_WORD , { "primIndexWordOffAddr", "AI", "W", MONAD_Id, i_PRIMOP1, i_indexWordOffAddr } -#endif , { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr } , { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr } , { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr } @@ -1352,12 +1178,7 @@ const AsmPrim asmPrimOps[] = { /* These ops really ought to be in the IO monad */ , { "primReadCharOffAddr", "AI", "C", MONAD_ST, i_PRIMOP1, i_readCharOffAddr } , { "primReadIntOffAddr", "AI", "I", MONAD_ST, i_PRIMOP1, i_readIntOffAddr } -#ifdef PROVIDE_INT64 - , { "primReadInt64OffAddr", "AI", "z", MONAD_ST, i_PRIMOP1, i_readInt64OffAddr } -#endif -#ifdef PROVIDE_WORD , { "primReadWordOffAddr", "AI", "W", MONAD_ST, i_PRIMOP1, i_readWordOffAddr } -#endif , { "primReadAddrOffAddr", "AI", "A", MONAD_ST, i_PRIMOP1, i_readAddrOffAddr } , { "primReadFloatOffAddr", "AI", "F", MONAD_ST, i_PRIMOP1, i_readFloatOffAddr } , { "primReadDoubleOffAddr", "AI", "D", MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr } @@ -1368,12 +1189,7 @@ const AsmPrim asmPrimOps[] = { /* These ops really ought to be in the IO monad */ , { "primWriteCharOffAddr", "AIC", "", MONAD_ST, i_PRIMOP1, i_writeCharOffAddr } , { "primWriteIntOffAddr", "AII", "", MONAD_ST, i_PRIMOP1, i_writeIntOffAddr } -#ifdef PROVIDE_INT64 - , { "primWriteInt64OffAddr", "AIz", "", MONAD_ST, i_PRIMOP1, i_writeInt64OffAddr } -#endif -#ifdef PROVIDE_WORD , { "primWriteWordOffAddr", "AIW", "", MONAD_ST, i_PRIMOP1, i_writeWordOffAddr } -#endif , { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr } , { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr } , { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr } @@ -1381,9 +1197,6 @@ const AsmPrim asmPrimOps[] = { , { "primWriteStableOffAddr", "AIs", "", MONAD_ST, i_PRIMOP1, i_writeStableOffAddr } #endif -#endif /* PROVIDE_ADDR */ - -#ifdef PROVIDE_INTEGER /* Integer operations */ , { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger } , { "primNegateInteger", "Z", "Z", MONAD_Id, i_PRIMOP1, i_negateInteger } @@ -1394,19 +1207,12 @@ const AsmPrim asmPrimOps[] = { , { "primDivModInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger } , { "primIntegerToInt", "Z", "I", MONAD_Id, i_PRIMOP1, i_integerToInt } , { "primIntToInteger", "I", "Z", MONAD_Id, i_PRIMOP1, i_intToInteger } -#ifdef PROVIDE_INT64 - , { "primIntegerToInt64", "Z", "z", MONAD_Id, i_PRIMOP1, i_integerToInt64 } - , { "primInt64ToInteger", "z", "Z", MONAD_Id, i_PRIMOP1, i_int64ToInteger } -#endif -#ifdef PROVIDE_WORD , { "primIntegerToWord", "Z", "W", MONAD_Id, i_PRIMOP1, i_integerToWord } , { "primWordToInteger", "W", "Z", MONAD_Id, i_PRIMOP1, i_wordToInteger } -#endif , { "primIntegerToFloat", "Z", "F", MONAD_Id, i_PRIMOP1, i_integerToFloat } , { "primFloatToInteger", "F", "Z", MONAD_Id, i_PRIMOP1, i_floatToInteger } , { "primIntegerToDouble", "Z", "D", MONAD_Id, i_PRIMOP1, i_integerToDouble } , { "primDoubleToInteger", "D", "Z", MONAD_Id, i_PRIMOP1, i_doubleToInteger } -#endif /* Float# operations */ , { "primGtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_gtFloat } @@ -1441,14 +1247,8 @@ const AsmPrim asmPrimOps[] = { , { "primCoshFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_coshFloat } , { "primTanhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanhFloat } , { "primPowerFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_powerFloat } -#ifdef PROVIDE_INT64 - , { "primDecodeFloatz", "F", "zI", MONAD_Id, i_PRIMOP1, i_decodeFloatz } - , { "primEncodeFloatz", "zI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatz } -#endif -#ifdef PROVIDE_INTEGER , { "primDecodeFloatZ", "F", "ZI", MONAD_Id, i_PRIMOP1, i_decodeFloatZ } , { "primEncodeFloatZ", "ZI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatZ } -#endif , { "primIsNaNFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNaNFloat } , { "primIsInfiniteFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteFloat } , { "primIsDenormalizedFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedFloat } @@ -1490,29 +1290,14 @@ const AsmPrim asmPrimOps[] = { , { "primCoshDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_coshDouble } , { "primTanhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanhDouble } , { "primPowerDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_powerDouble } -#ifdef PROVIDE_INT64 - , { "primDecodeDoublez", "D", "zI", MONAD_Id, i_PRIMOP1, i_decodeDoublez } - , { "primEncodeDoublez", "zI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoublez } -#endif -#ifdef PROVIDE_INTEGER , { "primDecodeDoubleZ", "D", "ZI", MONAD_Id, i_PRIMOP1, i_decodeDoubleZ } , { "primEncodeDoubleZ", "ZI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoubleZ } -#endif , { "primIsNaNDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNaNDouble } , { "primIsInfiniteDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteDouble } , { "primIsDenormalizedDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedDouble } , { "primIsNegativeZeroDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble } , { "primIsIEEEDouble", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEDouble } - - /* Polymorphic force :: a -> (# #) */ - /* , { "primForce", "a", "", MONAD_Id, i_PRIMOP2, i_force } */ - - /* Error operations - not in IO monad! */ - //, { "primRaise", "E", "a", MONAD_Id, i_PRIMOP2, i_raise } - //, { "primCatch'", "aH", "a", MONAD_Id, i_PRIMOP2, i_catch } - -#ifdef PROVIDE_ARRAY /* Ref operations */ , { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef } , { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef } @@ -1543,28 +1328,17 @@ const AsmPrim asmPrimOps[] = { , { "primReadIntArray", "mI", "I", MONAD_ST, i_PRIMOP2, i_readIntArray } , { "primIndexIntArray", "xI", "I", MONAD_Id, i_PRIMOP2, i_indexIntArray } -#ifdef PROVIDE_INT64 - , { "primWriteInt64Array", "mIz", "", MONAD_ST, i_PRIMOP2, i_writeInt64Array } - , { "primReadInt64Array", "mI", "z", MONAD_ST, i_PRIMOP2, i_readInt64Array } - , { "primIndexInt64Array", "xI", "z", MONAD_Id, i_PRIMOP2, i_indexInt64Array } -#endif - /* {new,write,read,index}IntegerArray not provided */ -#ifdef PROVIDE_WORD , { "primWriteWordArray", "mIW", "", MONAD_ST, i_PRIMOP2, i_writeWordArray } , { "primReadWordArray", "mI", "W", MONAD_ST, i_PRIMOP2, i_readWordArray } , { "primIndexWordArray", "xI", "W", MONAD_Id, i_PRIMOP2, i_indexWordArray } -#endif -#ifdef PROVIDE_ADDR , { "primWriteAddrArray", "mIA", "", MONAD_ST, i_PRIMOP2, i_writeAddrArray } , { "primReadAddrArray", "mI", "A", MONAD_ST, i_PRIMOP2, i_readAddrArray } , { "primIndexAddrArray", "xI", "A", MONAD_Id, i_PRIMOP2, i_indexAddrArray } -#endif , { "primWriteFloatArray", "mIF", "", MONAD_ST, i_PRIMOP2, i_writeFloatArray } , { "primReadFloatArray", "mI", "F", MONAD_ST, i_PRIMOP2, i_readFloatArray } , { "primIndexFloatArray", "xI", "F", MONAD_Id, i_PRIMOP2, i_indexFloatArray } - , { "primWriteDoubleArray" , "mID", "", MONAD_ST, i_PRIMOP2, i_writeDoubleArray } , { "primReadDoubleArray", "mI", "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray } , { "primIndexDoubleArray", "xI", "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray } @@ -1577,7 +1351,6 @@ const AsmPrim asmPrimOps[] = { /* {new,write,read,index}ForeignObjArray not provided */ -#endif PROVIDE_ARRAY #ifdef PROVIDE_FOREIGN /* ForeignObj# operations */ @@ -1651,10 +1424,10 @@ const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) AsmBCO asm_BCO_catch ( void ) { AsmBCO bco = asmBeginBCO(0 /*NIL*/); - emit_i1(bco,i_ARG_CHECK,2); - emit_i1(bco,i_PRIMOP1,i_pushcatchframe); + emiti_8(bco,i_ARG_CHECK,2); + emiti_8(bco,i_PRIMOP1,i_pushcatchframe); bco->sp += (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame); - emit_i0(bco,i_ENTER); + emiti_(bco,i_ENTER); asmEndBCO(bco); return bco; } @@ -1662,8 +1435,8 @@ AsmBCO asm_BCO_catch ( void ) AsmBCO asm_BCO_raise ( void ) { AsmBCO bco = asmBeginBCO(0 /*NIL*/); - emit_i1(bco,i_ARG_CHECK,1); - emit_i1(bco,i_PRIMOP2,i_raise); + emiti_8(bco,i_ARG_CHECK,1); + emiti_8(bco,i_PRIMOP2,i_raise); asmEndBCO(bco); return bco; } @@ -1673,21 +1446,21 @@ AsmBCO asm_BCO_seq ( void ) AsmBCO eval, cont; cont = asmBeginBCO(0 /*NIL*/); - emit_i1(cont,i_ARG_CHECK,2); + emiti_8(cont,i_ARG_CHECK,2); emit_i_VAR(cont,1); emit_i_SLIDE(cont,1,2); - emit_i0(cont,i_ENTER); + emiti_(cont,i_ENTER); cont->sp += 3*sizeofW(StgPtr); asmEndBCO(cont); eval = asmBeginBCO(0 /*NIL*/); - emit_i1(eval,i_ARG_CHECK,2); + emiti_8(eval,i_ARG_CHECK,2); emit_i_RETADDR(eval,eval->object.ptrs.len); asmPtr(eval,&(cont->object)); emit_i_VAR(eval,2); emit_i_SLIDE(eval,3,1); - emit_i1(eval,i_PRIMOP1,i_pushseqframe); - emit_i0(eval,i_ENTER); + emiti_8(eval,i_PRIMOP1,i_pushseqframe); + emiti_(eval,i_ENTER); eval->sp += sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr); asmEndBCO(eval); @@ -1701,7 +1474,7 @@ AsmBCO asm_BCO_seq ( void ) AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info ) { ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - emit_i1(bco,i_ALLOC_CONSTR,bco->nps.len); + emiti_8(bco,i_ALLOC_CONSTR,bco->nps.len); asmWords(bco,AsmInfo,info); bco->sp += sizeofW(StgClosurePtr); grabHpNonUpd(bco,sizeW_fromITBL(info)); @@ -1720,7 +1493,7 @@ void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info ) assert(start >= v); /* only reason to include info is for this assertion */ assert(info->layout.payload.ptrs == size); - emit_i1(bco,i_PACK,bco->sp - v); + emit_i_PACK(bco, bco->sp - v); bco->sp = start; } @@ -1731,12 +1504,12 @@ void asmBeginUnpack( AsmBCO bco ) void asmEndUnpack( AsmBCO bco ) { - emit_i0(bco,i_UNPACK); + emiti_(bco,i_UNPACK); } AsmVar asmAllocAP( AsmBCO bco, AsmNat words ) { - emit_i1(bco,i_ALLOC_AP,words); + emiti_8(bco,i_ALLOC_AP,words); bco->sp += sizeofW(StgPtr); grabHpUpd(bco,AP_sizeW(words)); return bco->sp; @@ -1756,7 +1529,7 @@ void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start ) AsmVar asmAllocPAP( AsmBCO bco, AsmNat size ) { - emit_i1(bco,i_ALLOC_PAP,size); + emiti_8(bco,i_ALLOC_PAP,size); bco->sp += sizeofW(StgPtr); return bco->sp; } @@ -1768,7 +1541,7 @@ AsmSp asmBeginMkPAP( AsmBCO bco ) void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start ) { - emit_i2(bco,i_MKPAP,bco->sp-v,bco->sp-start-1); + emiti_8_8(bco,i_MKPAP,bco->sp-v,bco->sp-start-1); /* -1 because fun isn't counted */ bco->sp = start; } @@ -1798,7 +1571,6 @@ AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs ) info->layout.payload.nptrs = nptrs; info->srt_len = tag; info->type = CONSTR; - info->flags = FLAGS_CONSTR; #ifdef USE_MINIINTERPRETER info->entry = stgCast(StgFunPtr,&Hugs_CONSTR_entry); #else diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index 3522072..d93f86e 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Bytecodes.h,v 1.5 1999/03/09 14:51:24 sewardj Exp $ + * $Id: Bytecodes.h,v 1.6 1999/04/27 10:07:20 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -23,113 +23,86 @@ * overflowing. * ------------------------------------------------------------------------*/ -typedef enum - { i_INTERNAL_ERROR /* Instruction 0 raises an internal error */ - - , i_PANIC /* irrefutable pattern match failed! */ - - , i_STK_CHECK - - , i_ARG_CHECK - - , i_ALLOC_AP - , i_ALLOC_PAP - , i_ALLOC_CONSTR - , i_MKAP - , i_MKAP_big - , i_MKPAP - , i_PACK - - , i_SLIDE - , i_SLIDE_big - - , i_TEST - , i_UNPACK - - , i_VAR - , i_VAR_big - , i_CONST - , i_CONST_big - , i_ENTER - - , i_RETADDR - , i_RETADDR_big - - , i_VOID - , i_RETURN_GENERIC - - , i_VAR_INT - , i_VAR_INT_big - , i_CONST_INT - , i_CONST_INT_big - , i_RETURN_INT - , i_PACK_INT - , i_UNPACK_INT - , i_TEST_INT - -#ifdef PROVIDE_INT64 - , i_VAR_INT64 - , i_CONST_INT64 - , i_RETURN_INT64 - , i_PACK_INT64 - , i_UNPACK_INT64 -#endif -#ifdef PROVIDE_INTEGER - , i_CONST_INTEGER - , i_CONST_INTEGER_big -#endif -#ifdef PROVIDE_WORD - , i_VAR_WORD - , i_CONST_WORD - , i_RETURN_WORD - , i_PACK_WORD - , i_UNPACK_WORD -#endif -#ifdef PROVIDE_ADDR - , i_VAR_ADDR - , i_VAR_ADDR_big - , i_CONST_ADDR - , i_CONST_ADDR_big - , i_RETURN_ADDR - , i_PACK_ADDR - , i_UNPACK_ADDR -#endif - , i_VAR_CHAR - , i_VAR_CHAR_big - , i_CONST_CHAR - , i_CONST_CHAR_big - , i_RETURN_CHAR - , i_PACK_CHAR - , i_UNPACK_CHAR - - , i_VAR_FLOAT - , i_VAR_FLOAT_big - , i_CONST_FLOAT - , i_CONST_FLOAT_big - , i_RETURN_FLOAT - , i_PACK_FLOAT - , i_UNPACK_FLOAT - - , i_VAR_DOUBLE - , i_VAR_DOUBLE_big - , i_CONST_DOUBLE - , i_CONST_DOUBLE_big - , i_RETURN_DOUBLE - , i_PACK_DOUBLE - , i_UNPACK_DOUBLE +#define INSTRLIST \ + Ins(i_INTERNAL_ERROR), \ + Ins(i_PANIC), \ + Ins(i_STK_CHECK), \ + Ins(i_ARG_CHECK), \ + Ins(i_ALLOC_AP), \ + Ins(i_ALLOC_PAP), \ + Ins(i_ALLOC_CONSTR), \ + Ins(i_MKAP), \ + Ins(i_MKAP_big), \ + Ins(i_MKPAP), \ + Ins(i_PACK), \ + Ins(i_PACK_big), \ + Ins(i_SLIDE), \ + Ins(i_SLIDE_big), \ + Ins(i_TEST), \ + Ins(i_UNPACK), \ + Ins(i_VAR), \ + Ins(i_VAR_big), \ + Ins(i_CONST), \ + Ins(i_CONST_big), \ + Ins(i_ENTER), \ + Ins(i_RETADDR), \ + Ins(i_RETADDR_big), \ + Ins(i_VOID), \ + Ins(i_VAR_INT), \ + Ins(i_VAR_INT_big), \ + Ins(i_CONST_INT), \ + Ins(i_CONST_INT_big), \ + Ins(i_PACK_INT), \ + Ins(i_UNPACK_INT), \ + Ins(i_TEST_INT), \ + Ins(i_CONST_INTEGER), \ + Ins(i_CONST_INTEGER_big), \ + Ins(i_VAR_WORD), \ + Ins(i_VAR_WORD_big), \ + Ins(i_CONST_WORD), \ + Ins(i_PACK_WORD), \ + Ins(i_UNPACK_WORD), \ + Ins(i_VAR_ADDR), \ + Ins(i_VAR_ADDR_big), \ + Ins(i_CONST_ADDR), \ + Ins(i_CONST_ADDR_big), \ + Ins(i_PACK_ADDR), \ + Ins(i_UNPACK_ADDR), \ + Ins(i_VAR_CHAR), \ + Ins(i_VAR_CHAR_big), \ + Ins(i_CONST_CHAR), \ + Ins(i_CONST_CHAR_big), \ + Ins(i_PACK_CHAR), \ + Ins(i_UNPACK_CHAR), \ + Ins(i_VAR_FLOAT), \ + Ins(i_VAR_FLOAT_big), \ + Ins(i_CONST_FLOAT), \ + Ins(i_CONST_FLOAT_big), \ + Ins(i_PACK_FLOAT), \ + Ins(i_UNPACK_FLOAT), \ + Ins(i_VAR_DOUBLE), \ + Ins(i_VAR_DOUBLE_big), \ + Ins(i_CONST_DOUBLE), \ + Ins(i_CONST_DOUBLE_big), \ + Ins(i_PACK_DOUBLE), \ + Ins(i_UNPACK_DOUBLE), \ + Ins(i_VAR_STABLE), \ + Ins(i_PACK_STABLE), \ + Ins(i_UNPACK_STABLE), \ + Ins(i_PRIMOP1), \ + Ins(i_PRIMOP2), \ + Ins(i_RV), \ + Ins(i_RVE), \ + Ins(i_SE), \ + Ins(i_VV) + +#define BIGGEST_OPCODE ((int)(i_VV)) + +#define Ins(x) x +typedef enum { INSTRLIST } Instr; +#undef Ins -#ifdef PROVIDE_STABLE - , i_VAR_STABLE - , i_RETURN_STABLE - , i_PACK_STABLE - , i_UNPACK_STABLE -#endif - , i_PRIMOP1 /* Primop: next byte is an Primop1 */ - , i_PRIMOP2 /* Primop: next byte is an Primop2 */ - - , MAX_Instr = i_PRIMOP2 -} Instr; typedef enum { i_INTERNAL_ERROR1 /* Instruction 0 raises an internal error */ @@ -171,42 +144,6 @@ typedef enum , i_shiftRAInt , i_shiftRLInt -#ifdef PROVIDE_INT64 - /* Int64# operations */ - , i_gtInt64 - , i_geInt64 - , i_eqInt64 - , i_neInt64 - , i_ltInt64 - , i_leInt64 - , i_minInt64 - , i_maxInt64 - , i_plusInt64 - , i_minusInt64 - , i_timesInt64 - , i_quotInt64 - , i_remInt64 - , i_quotRemInt64 - , i_negateInt64 - , i_andInt64 - , i_orInt64 - , i_xorInt64 - , i_notInt64 - , i_shiftLInt64 - , i_shiftRAInt64 - , i_shiftRLInt64 - , i_int64ToInt - , i_intToInt64 -#ifdef PROVIDE_WORD - , i_int64ToWord - , i_wordToInt64 -#endif - , i_int64ToFloat - , i_floatToInt64 - , i_int64ToDouble - , i_doubleToInt64 -#endif -#ifdef PROVIDE_WORD /* Word# operations */ , i_gtWord , i_geWord @@ -232,8 +169,7 @@ typedef enum , i_shiftRLWord , i_intToWord , i_wordToInt -#endif -#ifdef PROVIDE_ADDR + /* Addr# operations */ , i_gtAddr , i_geAddr @@ -247,15 +183,8 @@ typedef enum /* Stateless Addr operations */ , i_indexCharOffAddr , i_indexIntOffAddr -#ifdef PROVIDE_INT64 - , i_indexInt64OffAddr -#endif -#ifdef PROVIDE_WORD , i_indexWordOffAddr -#endif -#ifdef PROVIDE_ADDR , i_indexAddrOffAddr -#endif , i_indexFloatOffAddr , i_indexDoubleOffAddr #ifdef PROVIDE_STABLE @@ -264,15 +193,8 @@ typedef enum , i_readCharOffAddr , i_readIntOffAddr -#ifdef PROVIDE_INT64 - , i_readInt64OffAddr -#endif -#ifdef PROVIDE_WORD , i_readWordOffAddr -#endif -#ifdef PROVIDE_ADDR , i_readAddrOffAddr -#endif , i_readFloatOffAddr , i_readDoubleOffAddr #ifdef PROVIDE_STABLE @@ -281,24 +203,14 @@ typedef enum , i_writeCharOffAddr , i_writeIntOffAddr -#ifdef PROVIDE_INT64 - , i_writeInt64OffAddr -#endif -#ifdef PROVIDE_WORD , i_writeWordOffAddr -#endif -#ifdef PROVIDE_ADDR , i_writeAddrOffAddr -#endif , i_writeFloatOffAddr , i_writeDoubleOffAddr #ifdef PROVIDE_STABLE , i_writeStableOffAddr #endif -#endif /* PROVIDE_ADDR */ - -#ifdef PROVIDE_INTEGER /* Integer operations */ , i_compareInteger , i_negateInteger @@ -309,19 +221,12 @@ typedef enum , i_divModInteger , i_integerToInt , i_intToInteger -#ifdef PROVIDE_INT64 - , i_integerToInt64 - , i_int64ToInteger -#endif -#ifdef PROVIDE_WORD , i_integerToWord , i_wordToInteger -#endif , i_integerToFloat , i_floatToInteger , i_integerToDouble , i_doubleToInteger -#endif /* Float# operations */ , i_gtFloat @@ -356,14 +261,8 @@ typedef enum , i_coshFloat , i_tanhFloat , i_powerFloat -#ifdef PROVIDE_INT64 - , i_decodeFloatz - , i_encodeFloatz -#endif -#ifdef PROVIDE_INTEGER , i_decodeFloatZ , i_encodeFloatZ -#endif , i_isNaNFloat , i_isInfiniteFloat , i_isDenormalizedFloat @@ -405,14 +304,8 @@ typedef enum , i_coshDouble , i_tanhDouble , i_powerDouble -#ifdef PROVIDE_INT64 - , i_decodeDoublez - , i_encodeDoublez -#endif -#ifdef PROVIDE_INTEGER , i_decodeDoubleZ , i_encodeDoubleZ -#endif , i_isNaNDouble , i_isInfiniteDouble , i_isDenormalizedDouble @@ -432,7 +325,6 @@ typedef enum , i_raise -#ifdef PROVIDE_ARRAY /* Ref operations */ , i_newRef , i_writeRef @@ -463,28 +355,17 @@ typedef enum , i_readIntArray , i_indexIntArray -#ifdef PROVIDE_INT64 - , i_writeInt64Array - , i_readInt64Array - , i_indexInt64Array -#endif - /* {write,read,index}IntegerArray not provided */ -#ifdef PROVIDE_WORD , i_writeWordArray , i_readWordArray , i_indexWordArray -#endif -#ifdef PROVIDE_ADDR , i_writeAddrArray , i_readAddrArray , i_indexAddrArray -#endif , i_writeFloatArray , i_readFloatArray , i_indexFloatArray - , i_writeDoubleArray , i_readDoubleArray , i_indexDoubleArray @@ -497,8 +378,6 @@ typedef enum /* {write,read,index}ForeignObjArray not provided */ -#endif /* PROVIDE_ARRAY */ - #ifdef PROVIDE_PTREQUALITY , i_reallyUnsafePtrEquality #endif diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index c1f29ee..9cd5054 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Disassembler.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/09 14:51:23 $ + * $Revision: 1.6 $ + * $Date: 1999/04/27 10:07:19 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -41,7 +41,7 @@ static InstrPtr disNone ( StgBCO *bco, InstrPtr pc, char* i ) static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i ) { StgInt x = bcoInstr(bco,pc++); - ASSERT(pc < bco->n_instrs); + ASSERT(pc <= bco->n_instrs); fprintf(stderr,"%s %d",i,x); return pc; } @@ -49,7 +49,7 @@ static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i ) static InstrPtr disInt16 ( StgBCO *bco, InstrPtr pc, char* i ) { StgInt x = bcoInstr16(bco,pc); pc+=2; - ASSERT(pc < bco->n_instrs); + ASSERT(pc <= bco->n_instrs); fprintf(stderr,"%s %d",i,x); return pc; } @@ -223,6 +223,14 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disInt(bco,pc,"PACK"); case i_SLIDE: return disIntInt(bco,pc,"SLIDE"); + case i_RV: + return disIntInt(bco,pc,"R_V"); + case i_RVE: + return disIntInt(bco,pc,"R_V_E"); + case i_VV: + return disIntInt(bco,pc,"V_V"); + case i_SE: + return disIntInt(bco,pc,"S_E"); case i_SLIDE_big: return disIntInt16(bco,pc,"SLIDE_big"); case i_ENTER: @@ -246,8 +254,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_VOID: return disNone(bco,pc,"VOID"); - case i_RETURN_GENERIC: - return disNone(bco,pc,"RETURN_GENERIC"); case i_VAR_INT: return disInt(bco,pc,"VAR_INT"); @@ -257,8 +263,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disConstInt(bco,pc,"CONST_INT"); case i_CONST_INT_big: return disConstInt16(bco,pc,"CONST_INT_big"); - case i_RETURN_INT: - return disNone(bco,pc,"RETURN_INT"); case i_PACK_INT: return disNone(bco,pc,"PACK_INT"); case i_UNPACK_INT: @@ -266,37 +270,20 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_TEST_INT: return disPC(bco,pc,"TEST_INT"); -#ifdef PROVIDE_INT64 - case i_VAR_INT64: - return disInt(bco,pc,"VAR_INT64"); - case i_CONST_INT64: - return disConstInt(bco,pc,"CONST_INT64"); - case i_RETURN_INT64: - return disNone(bco,pc,"RETURN_INT64"); - case i_PACK_INT64: - return disNone(bco,pc,"PACK_INT64"); - case i_UNPACK_INT64: - return disNone(bco,pc,"UNPACK_INT64"); -#endif -#ifdef PROVIDE_INTEGER case i_CONST_INTEGER: return disConstAddr(bco,pc,"CONST_INTEGER"); case i_CONST_INTEGER_big: return disConstAddr16(bco,pc,"CONST_INTEGER_big"); -#endif -#ifdef PROVIDE_WORD + case i_VAR_WORD: return disInt(bco,pc,"VAR_WORD"); case i_CONST_WORD: return disConstInt(bco,pc,"CONST_WORD"); - case i_RETURN_WORD: - return disNone(bco,pc,"RETURN_WORD"); case i_PACK_WORD: return disNone(bco,pc,"PACK_WORD"); case i_UNPACK_WORD: return disNone(bco,pc,"UNPACK_WORD"); -#endif -#ifdef PROVIDE_ADDR + case i_VAR_ADDR: return disInt(bco,pc,"VAR_ADDR"); case i_VAR_ADDR_big: @@ -305,13 +292,11 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disConstAddr(bco,pc,"CONST_ADDR"); case i_CONST_ADDR_big: return disConstAddr16(bco,pc,"CONST_ADDR_big"); - case i_RETURN_ADDR: - return disNone(bco,pc,"RETURN_ADDR"); case i_PACK_ADDR: return disNone(bco,pc,"PACK_ADDR"); case i_UNPACK_ADDR: return disNone(bco,pc,"UNPACK_ADDR"); -#endif + case i_VAR_CHAR: return disInt(bco,pc,"VAR_CHAR"); case i_VAR_CHAR_big: @@ -320,8 +305,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disConstChar(bco,pc,"CONST_CHAR"); case i_CONST_CHAR_big: return disConstChar16(bco,pc,"CONST_CHAR_big"); - case i_RETURN_CHAR: - return disNone(bco,pc,"RETURN_CHAR"); case i_PACK_CHAR: return disNone(bco,pc,"PACK_CHAR"); case i_UNPACK_CHAR: @@ -335,8 +318,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disConstFloat(bco,pc,"CONST_FLOAT"); case i_CONST_FLOAT_big: return disConstFloat16(bco,pc,"CONST_FLOAT_big"); - case i_RETURN_FLOAT: - return disNone(bco,pc,"RETURN_FLOAT"); case i_PACK_FLOAT: return disNone(bco,pc,"PACK_FLOAT"); case i_UNPACK_FLOAT: @@ -350,8 +331,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disConstDouble(bco,pc,"CONST_DOUBLE"); case i_CONST_DOUBLE_big: return disConstDouble16(bco,pc,"CONST_DOUBLE_big"); - case i_RETURN_DOUBLE: - return disNone(bco,pc,"RETURN_DOUBLE"); case i_PACK_DOUBLE: return disNone(bco,pc,"PACK_DOUBLE"); case i_UNPACK_DOUBLE: @@ -360,8 +339,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) #ifdef PROVIDE_STABLE case i_VAR_STABLE: return disInt(bco,pc,"VAR_STABLE"); - case i_RETURN_STABLE: - return disNone(bco,pc,"RETURN_STABLE"); case i_PACK_STABLE: return disNone(bco,pc,"PACK_STABLE"); case i_UNPACK_STABLE: diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 5a6b0bc..06a3613 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.11 $ - * $Date: 1999/03/09 14:51:21 $ + * $Revision: 1.12 $ + * $Date: 1999/04/27 10:07:16 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -41,10 +41,14 @@ #ifdef HAVE_IEEE754_H #include /* These are for primops */ #endif -#ifdef PROVIDE_INTEGER -#include "gmp.h" /* These are for primops */ + +#ifdef STANDALONE_INTEGER +#include "sainteger.h" +#else +#error Non-standalone integer not yet supported #endif + /* An incredibly useful abbreviation. * Interestingly, there are some uses of END_TSO_QUEUE_closure that * can't use it because they use the closure at type StgClosure* or @@ -60,10 +64,178 @@ #define mycat2(x,y) mycat(x,y) #define mycat3(x,y,z) mycat2(x,mycat2(y,z)) +#if defined(__GNUC__) && !defined(DEBUG) +#define USE_GCC_LABELS 1 +#else +#define USE_GCC_LABELS 0 +#endif + +/* -------------------------------------------------------------------------- + * Crude profiling stuff (mainly to assess effect of optimiser) + * ------------------------------------------------------------------------*/ + +#if CRUDE_PROFILING + +#define M_CPTAB 10000 +#define CP_NIL (-1) + +int cpInUse = -1; +int cpCurr; + +typedef + struct { int /*StgVar*/ who; + int /*StgVar*/ twho; + int enters; + int bytes; + int insns; + } + CPRecord; + +CPRecord cpTab[M_CPTAB]; + +void cp_init ( void ) +{ + int i; + cpCurr = CP_NIL; + cpInUse = 0; + for (i = 0; i < M_CPTAB; i++) + cpTab[i].who = CP_NIL; +} + + +void cp_enter ( StgBCO* b ) +{ + int is_ret_cont; + int h; + int /*StgVar*/ v = b->stgexpr; + if ((void*)v == NULL) return; + + is_ret_cont = 0; + if (v > 500000000) { + is_ret_cont = 1; + v -= 1000000000; + } + + if (v < 0) + h = (-v) % M_CPTAB; else + h = v % M_CPTAB; + + assert (h >= 0 && h < M_CPTAB); + while (cpTab[h].who != v && cpTab[h].who != CP_NIL) { + h++; if (h == M_CPTAB) h = 0; + }; + cpCurr = h; + if (cpTab[cpCurr].who == CP_NIL) { + cpTab[cpCurr].who = v; + if (!is_ret_cont) cpTab[cpCurr].enters = 1; + cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0; + cpInUse++; + if (cpInUse * 2 > M_CPTAB) { + fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" ); + assert(0); + } + } else { + if (!is_ret_cont) cpTab[cpCurr].enters++; + } + + +} + +void cp_bill_words ( int nw ) +{ + if (cpCurr == CP_NIL) return; + cpTab[cpCurr].bytes += sizeof(StgWord)*nw; +} + + +void cp_bill_insns ( int ni ) +{ + if (cpCurr == CP_NIL) return; + cpTab[cpCurr].insns += ni; +} + + +static double percent ( double a, double b ) +{ + return (100.0 * a) / b; +} + + +void cp_show ( void ) +{ + int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI; + char nm[200]; + + if (cpInUse == -1) return; + + fflush(stdout);fflush(stderr); + printf ( "\n\n" ); + + totE = totB = totI = 0; + for (i = 0; i < M_CPTAB; i++) { + cpTab[i].twho = cpTab[i].who; + if (cpTab[i].who != CP_NIL) { + totE += cpTab[i].enters; + totB += cpTab[i].bytes; + totI += cpTab[i].insns; + } + } + + printf ( "Totals: " + "%6d (%7.3f M) enters, " + "%6d (%7.3f M) insns, " + "%6d (%7.3f M) bytes\n\n", + totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 ); + + cumE = cumB = cumI = 0; + for (j = 0; j < 32; j++) { + + maxN = max = -1; + for (i = 0; i < M_CPTAB; i++) + if (cpTab[i].who != CP_NIL && + cpTab[i].enters > maxN) { + maxN = cpTab[i].enters; + max = i; + } + if (max == -1) break; + + cumE += cpTab[max].enters; + cumB += cpTab[max].bytes; + cumI += cpTab[max].insns; + + strcpy(nm, maybeName(cpTab[max].who)); + if (strcmp(nm, "(unknown)")==0) + sprintf ( nm, "id%d", -cpTab[max].who); + + printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) " + "%7d bs (%4.1f%%, %4.1f%% c) " + "%7d is (%4.1f%%, %4.1f%% c)\n", + nm, + cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE), + cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB), + cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI) + ); + + cpTab[max].twho = cpTab[max].who; + cpTab[max].who = CP_NIL; + } + + for (i = 0; i < M_CPTAB; i++) + cpTab[i].who = cpTab[i].twho; + + printf ( "\n" ); +} + +#endif + + /* -------------------------------------------------------------------------- * Hugs Hooks - a bit of a hack * ------------------------------------------------------------------------*/ +/* A total hack -- this code has an endian dependancy and only works + on little-endian archs. +*/ void setRtsFlags( int x ); void setRtsFlags( int x ) { @@ -99,292 +271,1374 @@ void defaultsHook (void) /* do nothing */ } + /* -------------------------------------------------------------------------- - * MPZ helpers + * Entering-objects and bytecode interpreter part of evaluator * ------------------------------------------------------------------------*/ -#ifdef PROVIDE_INTEGER -static inline mpz_ptr mpz_alloc ( void ); -//static inline void mpz_free ( mpz_ptr ); +/* The primop (and all other) parts of this evaluator operate upon the + machine state which lives in MainRegTable. enter is different: + to make its closure- and bytecode-interpreting loops go fast, some of that + state is pulled out into local vars (viz, registers, if we are lucky). + That means that we need to save(load) the local state at every exit(reentry) + into enter. That is, around every procedure call it makes. Blargh! + If you modify this code, __be warned__ it will fail in mysterious ways if + you fail to preserve this property. + + Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim. + The SSS macros saves the state back in MainRegTable, and LLL loads it from + MainRegTable. RETURN(v) does SSS and then returns v; all exits should + be via RETURN and not plain return. + + Since xSp, xSu and xSpLim are local vars in enter, they are not visible + in procedures called from enter. To fix this, either (1) turn the + procedures into macros, so they get copied inline, or (2) bracket + the procedure call with SSS and LLL so that the local and global + machine states are synchronised for the duration of the call. +*/ + + +/* Forward decls ... */ +static void* enterBCO_primop1 ( int ); +static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */ ); +static inline void PopUpdateFrame ( StgClosure* obj ); +static inline void PopCatchFrame ( void ); +static inline void PopSeqFrame ( void ); +static inline void PopStopFrame( StgClosure* obj ); +static inline void PushTaggedRealWorld( void ); +static inline void PushTaggedInteger ( mpz_ptr ); +static inline StgPtr grabHpUpd( nat size ); +static inline StgPtr grabHpNonUpd( nat size ); +static StgClosure* raiseAnError ( StgClosure* errObj ); -static inline mpz_ptr mpz_alloc ( void ) -{ - mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc")); - mpz_init(r); - return r; -} +static int enterCountI = 0; -#if 0 /* apparently unused */ -static inline void mpz_free ( mpz_ptr a ) -{ - mpz_clear(a); - free(a); -} +#ifdef STANDALONE_INTEGER +StgDouble B__encodeDouble (B* s, I_ e); +void B__decodeDouble (B* man, I_* exp, StgDouble dbl); +#if ! FLOATS_AS_DOUBLES +StgFloat B__encodeFloat (B* s, I_ e); +void B__decodeFloat (B* man, I_* exp, StgFloat flt); +StgPtr CreateByteArrayToHoldInteger ( int ); +B* IntegerInsideByteArray ( StgPtr ); +void SloppifyIntegerEnd ( StgPtr ); #endif #endif -/* -------------------------------------------------------------------------- - * - * ------------------------------------------------------------------------*/ -/*static*/ inline void PushTag ( StackTag t ); -/*static*/ inline void PushPtr ( StgPtr x ); -/*static*/ inline void PushCPtr ( StgClosure* x ); -/*static*/ inline void PushInt ( StgInt x ); -/*static*/ inline void PushWord ( StgWord x ); - -/*static*/ inline void PushTag ( StackTag t ) { *(--Sp) = t; } -/*static*/ inline void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; } -/*static*/ inline void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; } -/*static*/ inline void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; } -/*static*/ inline void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; } - -/*static*/ inline void checkTag ( StackTag t1, StackTag t2 ); -/*static*/ inline void PopTag ( StackTag t ); -/*static*/ inline StgPtr PopPtr ( void ); -/*static*/ inline StgClosure* PopCPtr ( void ); -/*static*/ inline StgInt PopInt ( void ); -/*static*/ inline StgWord PopWord ( void ); - -/*static*/ inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);} -/*static*/ inline void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); } -/*static*/ inline StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; } -/*static*/ inline StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; } -/*static*/ inline StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; } -/*static*/ inline StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; } - -/*static*/ inline StgPtr stackPtr ( StgStackOffset i ); -/*static*/ inline StgInt stackInt ( StgStackOffset i ); -/*static*/ inline StgWord stackWord ( StgStackOffset i ); - -/*static*/ inline StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); } -/*static*/ inline StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); } -/*static*/ inline StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); } - -/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ); -/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; } - -/*static*/ inline void PushTaggedRealWorld( void ); -/*static*/ inline void PushTaggedInt ( StgInt x ); -#ifdef PROVIDE_INT64 -/*static*/ inline void PushTaggedInt64 ( StgInt64 x ); -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline void PushTaggedInteger ( mpz_ptr x ); -#endif -#ifdef PROVIDE_WORD -/*static*/ inline void PushTaggedWord ( StgWord x ); -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline void PushTaggedAddr ( StgAddr x ); -#endif -/*static*/ inline void PushTaggedChar ( StgChar x ); -/*static*/ inline void PushTaggedFloat ( StgFloat x ); -/*static*/ inline void PushTaggedDouble ( StgDouble x ); -/*static*/ inline void PushTaggedStablePtr ( StgStablePtr x ); -/*static*/ inline void PushTaggedBool ( int x ); - -/*static*/ inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); } -/*static*/ inline void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); } -#ifdef PROVIDE_INT64 -/*static*/ inline void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); } -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline void PushTaggedInteger ( mpz_ptr x ) + +/* Macros to save/load local state. */ +#if DEBUG +#define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; } +#define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; } +#else +#define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; } +#define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; } +#endif + +#define RETURN(vvv) { StgThreadReturnCode retVal=(vvv); SSS; return retVal; } + + +/* Macros to operate directly on the pulled-out machine state. + These mirror some of the small procedures used in the primop code + below, except you have to be careful about side effects, + ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the + same as PushPtr(StackPtr(n)). Also note that (1) some of + the macros, in particular xPopTagged*, do not make the tag + sanity checks that their non-x cousins do, and (2) some of + the macros depend critically on the semantics of C comma + expressions to work properly +*/ +#define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } +#define xPopPtr() ((StgPtr)(*xSp++)) + +#define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } +#define xPopCPtr() ((StgClosure*)(*xSp++)) + +#define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); } +#define xPopWord() ((StgWord)(*xSp++)) + +#define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn)))) +#define xStackWord(nnn) ((StgWord)(*(xSp+(nnn)))) +#define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www) + +#define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); } +#define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \ + ASSERT(t == ttt); } + +#define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \ + *xSp = (xxx); xPushTag(INT_TAG); } +#define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii)))) +#define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \ + (StgInt)(*(xSp-sizeofW(StgInt))))) + +#define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \ + *xSp = (xxx); xPushTag(WORD_TAG); } +#define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii)))) +#define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \ + (StgWord)(*(xSp-sizeofW(StgWord))))) + +#define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \ + *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); } +#define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii)))) +#define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \ + (StgAddr)(*(xSp-sizeofW(StgAddr))))) + +#define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \ + *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); } +#define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii)))) +#define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \ + (StgChar)(*(xSp-sizeofW(StgChar))))) + +#define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \ + ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); } +#define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii)) +#define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \ + PK_FLT(xSp-sizeofW(StgFloat)))) + +#define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \ + ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); } +#define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii)) +#define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \ + PK_DBL(xSp-sizeofW(StgDouble)))) + + +#define xPopUpdateFrame(ooo) \ +{ \ + /* NB: doesn't assume that Sp == Su */ \ + IF_DEBUG(evaluator, \ + fprintf(stderr, "Updating "); \ + printPtr(stgCast(StgPtr,xSu->updatee)); \ + fprintf(stderr, " with "); \ + printObj(ooo); \ + fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \ + ); \ + UPD_IND(xSu->updatee,ooo); \ + xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \ + xSu = xSu->link; \ +} + + + +/* Instruction stream macros */ +#define BCO_INSTR_8 *bciPtr++ +#define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1))) +#define PC (bciPtr - &(bcoInstr(bco,0))) + + +StgThreadReturnCode enter( StgClosure* obj0 ) { - StgForeignObj *result; - //StgWeak *w; - - result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); - SET_HDR(result,&FOREIGN_info,CCCS); - result -> data = x; - -#if 0 /* For now we don't deallocate Integer's at all */ - w = stgCast(StgWeak*,allocate(sizeofW(StgWeak))); - SET_HDR(w, &WEAK_info, CCCS); - w->key = stgCast(StgClosure*,result); - w->value = stgCast(StgClosure*,result); /* or any other closure you have handy */ - w->finaliser = funPtrToIO(mpz_free); - w->link = weak_ptr_list; - weak_ptr_list = w; - IF_DEBUG(weak, fprintf(stderr,"New weak pointer watching Foreign MPZ at %p\n",w)); -#endif + /* use of register here is primarily to make it clear to compilers + that these entities are non-aliasable. + */ + register StgPtr xSp; /* local state -- stack pointer */ + register StgUpdateFrame* xSu; /* local state -- frame pointer */ + register StgPtr xSpLim; /* local state -- stack lim pointer */ + register StgClosure* obj; /* object currently under evaluation */ + char eCount; /* enter counter, for context switching */ - PushPtr(stgCast(StgPtr,result)); -} -#endif -#ifdef PROVIDE_WORD -/*static*/ inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } -#endif -/*static*/ inline void PushTaggedChar ( StgChar x ) -{ Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); } - -/*static*/ inline void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); } -/*static*/ inline void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); } -/*static*/ inline void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); } -/*static*/ inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } - -/*static*/ inline void PopTaggedRealWorld ( void ); -/*static*/ inline StgInt PopTaggedInt ( void ); -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 PopTaggedInt64 ( void ); -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline mpz_ptr PopTaggedInteger ( void ); -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord PopTaggedWord ( void ); -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr PopTaggedAddr ( void ); -#endif -/*static*/ inline StgChar PopTaggedChar ( void ); -/*static*/ inline StgFloat PopTaggedFloat ( void ); -/*static*/ inline StgDouble PopTaggedDouble ( void ); -/*static*/ inline StgStablePtr PopTaggedStablePtr ( void ); - -/*static*/ inline void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); } -/*static*/ inline StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;} -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;} -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);} -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;} -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;} -#endif -/*static*/ inline StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); Sp += sizeofW(StgChar); return r;} -/*static*/ inline StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;} -/*static*/ inline StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;} -/*static*/ inline StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;} - -/*static*/ inline StgInt taggedStackInt ( StgStackOffset i ); -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i ); -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord taggedStackWord ( StgStackOffset i ); -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ); -#endif -/*static*/ inline StgChar taggedStackChar ( StgStackOffset i ); -/*static*/ inline StgFloat taggedStackFloat ( StgStackOffset i ); -/*static*/ inline StgDouble taggedStackDouble ( StgStackOffset i ); -/*static*/ inline StgStablePtr taggedStackStable ( StgStackOffset i ); - -/*static*/ inline StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); } -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); } -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); } -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); } +#if DEBUG + /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ + StgPtr tSp = Sp; StgUpdateFrame* tSu = Su; StgPtr tSpLim = SpLim; #endif -/*static*/ inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; } + obj = obj0; + eCount = 0; + /* Load the local state from global state, and Party On, Dudes! */ + /* From here onwards, we operate with the local state and + save/reload it as necessary. + */ + LLL; -/*static*/ inline StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); } -/*static*/ inline StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); } -/*static*/ inline StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); } + enterLoop: +#if DEBUG + assert(Sp == tSp); + assert(Su == tSu); + assert(SpLim == tSpLim); + IF_DEBUG(evaluator, + SSS; + enterCountI++; + ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu)); + fprintf(stderr, + "\n---------------------------------------------------------------\n"); + fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj); + fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); + fprintf(stderr, "\n" ); + printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu); + fprintf(stderr, "\n\n"); + LLL; + ); +#endif -/* -------------------------------------------------------------------------- - * Heap allocation - * - * Should we allocate from a nursery or use the - * doYouWantToGC/allocate interface? We'd already implemented a - * nursery-style scheme when the doYouWantToGC/allocate interface - * was implemented. - * One reason to prefer the doYouWantToGC/allocate interface is to - * support operations which allocate an unknown amount in the heap - * (array ops, gmp ops, etc) - * ------------------------------------------------------------------------*/ + if (++eCount == 0) { + if (context_switch) { + xPushCPtr(obj); /* code to restart with */ + RETURN(ThreadYielding); + } + } -static inline StgPtr grabHpUpd( nat size ) -{ - ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); -} + switch ( get_itbl(obj)->type ) { + case INVALID_OBJECT: + barf("Invalid object %p",obj); -static inline StgPtr grabHpNonUpd( nat size ) -{ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); -} + case BCO: bco_entry: -/* -------------------------------------------------------------------------- - * Manipulate "update frame" list: - * o Update frames (based on stg_do_update and friends in Updates.hc) - * o Error handling/catching (based on catchzh_fast and friends in Prims.hc) - * o Seq frames (based on seq_frame_entry in Prims.hc) - * o Stop frames - * ------------------------------------------------------------------------*/ + /* ---------------------------------------------------- */ + /* Start of the bytecode evaluator */ + /* ---------------------------------------------------- */ + { +# if !DEBUG && USE_GCC_LABELS +# define Ins(x) &&l##x + static void *labs[] = { INSTRLIST }; +# undef Ins +# define LoopTopLabel +# define Case(x) l##x +# define Continue goto *labs[BCO_INSTR_8] +# define Dispatch Continue; +# define EndDispatch +# else +# define LoopTopLabel insnloop: +# define Case(x) case x +# define Continue goto insnloop +# define Dispatch switch (BCO_INSTR_8) { +# define EndDispatch } +# endif + + register StgWord8* bciPtr; /* instruction pointer */ + register StgBCO* bco = (StgBCO*)obj; + StgWord wantToGC; + + /* Don't need to SSS ... LLL around doYouWantToGC */ + wantToGC = doYouWantToGC(); + if (wantToGC) { + xPushCPtr((StgClosure*)bco); /* code to restart with */ + RETURN(HeapOverflow); + } -static inline void PopUpdateFrame ( StgClosure* obj ); -static inline void PushCatchFrame ( StgClosure* catcher ); -static inline void PopCatchFrame ( void ); -static inline void PushSeqFrame ( void ); -static inline void PopSeqFrame ( void ); +# if CRUDE_PROFILING + cp_enter ( bco ); +# endif + + + bciPtr = &(bcoInstr(bco,0)); + + LoopTopLabel + + ASSERT(PC < bco->n_instrs); + IF_DEBUG(evaluator, + fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC); + SSS; + disInstr(bco,PC); + //{ int i; + //fprintf(stderr,"\n"); + // for (i = 4; i >= 0; i--) + // fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i))); + // } + fprintf(stderr,"\n"); + LLL; + ); + +# if CRUDE_PROFILING + SSS; cp_bill_insns(1); LLL; +# endif + + Dispatch + + Case(i_INTERNAL_ERROR): + barf("INTERNAL_ERROR at %p:%d",bco,PC-1); + Case(i_PANIC): + barf("PANIC at %p:%d",bco,PC-1); + Case(i_STK_CHECK): + { + int n = BCO_INSTR_8; + if (xSp - n < xSpLim) { + xPushCPtr((StgClosure*)bco); /* code to restart with */ + RETURN(StackOverflow); + } + Continue; + } + Case(i_ARG_CHECK): + { + nat n = BCO_INSTR_8; + if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) { + StgWord words = (P_)xSu - xSp; + + /* first build a PAP */ + ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */ + if (words == 0) { /* optimisation */ + /* Skip building the PAP and update with an indirection. */ + } else { + /* Build the PAP. */ + /* In the evaluator, we avoid the need to do + * a heap check here by including the size of + * the PAP in the heap check we performed + * when we entered the BCO. + */ + StgInt i; + StgPAP* pap; + SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL; + SET_HDR(pap,&PAP_info,CC_pap); + pap->n_args = words; + pap->fun = obj; + for (i = 0; i < (I_)words; ++i) { + payloadWord(pap,i) = xSp[i]; + } + xSp += words; + obj = stgCast(StgClosure*,pap); + } + + /* now deal with "update frame" */ + /* as an optimisation, we process all on top of stack */ + /* instead of just the top one */ + ASSERT(xSp==(P_)xSu); + do { + switch (get_itbl(xSu)->type) { + case CATCH_FRAME: + /* Hit a catch frame during an arg satisfaction check, + * so the thing returning (1) has not thrown an + * exception, and (2) is of functional type. Just + * zap the catch frame and carry on down the stack + * (looking for more arguments, basically). + */ + SSS; PopCatchFrame(); LLL; + break; + case UPDATE_FRAME: + xPopUpdateFrame(obj); + break; + case STOP_FRAME: + SSS; PopStopFrame(obj); LLL; + RETURN(ThreadFinished); + case SEQ_FRAME: + SSS; PopSeqFrame(); LLL; + ASSERT(xSp != (P_)xSu); + /* Hit a SEQ frame during an arg satisfaction check. + * So now return to bco_info which is under the + * SEQ frame. The following code is copied from a + * case RET_BCO further down. (The reason why we're + * here is that something of functional type has + * been seq-d on, and we're now returning to the + * algebraic-case-continuation which forced the + * evaluation in the first place.) + */ + { + StgClosure* ret; + (void)xPopPtr(); + ret = xPopCPtr(); + xPushPtr((P_)obj); + obj = ret; + goto enterLoop; + } + break; + default: + barf("Invalid update frame during argcheck"); + } + } while (xSp==(P_)xSu); + goto enterLoop; + } + Continue; + } + Case(i_ALLOC_AP): + { + StgPtr p; + int words = BCO_INSTR_8; + SSS; p = grabHpUpd(AP_sizeW(words)); LLL; + xPushPtr(p); + Continue; + } + Case(i_ALLOC_CONSTR): + { + StgPtr p; + StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8); + SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL; + SET_HDR((StgClosure*)p,info,??); + xPushPtr(p); + Continue; + } + Case(i_MKAP): + { + int x = BCO_INSTR_8; /* ToDo: Word not Int! */ + int y = BCO_INSTR_8; + StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x)); + SET_HDR(o,&AP_UPD_info,??); + o->n_args = y; + o->fun = stgCast(StgClosure*,xPopPtr()); + for(x=0; x < y; ++x) { + payloadWord(o,x) = xPopWord(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + Continue; + } + Case(i_MKAP_big): + { + int x, y; + StgAP_UPD* o; + x = BCO_INSTR_16; + y = BCO_INSTR_16; + o = stgCast(StgAP_UPD*,xStackPtr(x)); + SET_HDR(o,&AP_UPD_info,??); + o->n_args = y; + o->fun = stgCast(StgClosure*,xPopPtr()); + for(x=0; x < y; ++x) { + payloadWord(o,x) = xPopWord(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + Continue; + } + Case(i_MKPAP): + { + int x = BCO_INSTR_8; + int y = BCO_INSTR_8; + StgPAP* o = stgCast(StgPAP*,xStackPtr(x)); + SET_HDR(o,&PAP_info,??); + o->n_args = y; + o->fun = stgCast(StgClosure*,xPopPtr()); + for(x=0; x < y; ++x) { + payloadWord(o,x) = xPopWord(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + Continue; + } + Case(i_PACK): + { + int offset = BCO_INSTR_8; + StgClosure* o = stgCast(StgClosure*,xStackPtr(offset)); + const StgInfoTable* info = get_itbl(o); + nat p = info->layout.payload.ptrs; + nat np = info->layout.payload.nptrs; + nat i; + for(i=0; i < p; ++i) { + payloadCPtr(o,i) = xPopCPtr(); + } + for(i=0; i < np; ++i) { + payloadWord(o,p+i) = 0xdeadbeef; + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + Continue; + } + Case(i_PACK_big): + { + int offset = BCO_INSTR_16; + StgClosure* o = stgCast(StgClosure*,xStackPtr(offset)); + const StgInfoTable* info = get_itbl(o); + nat p = info->layout.payload.ptrs; + nat np = info->layout.payload.nptrs; + nat i; + for(i=0; i < p; ++i) { + payloadCPtr(o,i) = xPopCPtr(); + } + for(i=0; i < np; ++i) { + payloadWord(o,p+i) = 0xdeadbeef; + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + Continue; + } + Case(i_SLIDE): + { + int x = BCO_INSTR_8; + int y = BCO_INSTR_8; + ASSERT(xSp+x+y <= stgCast(StgPtr,xSu)); + /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ + while(--x >= 0) { + xSetStackWord(x+y,xStackWord(x)); + } + xSp += y; + Continue; + } + Case(i_SLIDE_big): + { + int x, y; + x = BCO_INSTR_16; + y = BCO_INSTR_16; + ASSERT(xSp+x+y <= stgCast(StgPtr,xSu)); + /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ + while(--x >= 0) { + xSetStackWord(x+y,xStackWord(x)); + } + xSp += y; + Continue; + } + Case(i_ENTER): + { + obj = xPopCPtr(); + goto enterLoop; + } + Case(i_RETADDR): + { + xPushPtr(bcoConstPtr(bco,BCO_INSTR_8)); + xPushPtr(stgCast(StgPtr,&ret_bco_info)); + Continue; + } + Case(i_TEST): + { + int tag = BCO_INSTR_8; + StgWord offset = BCO_INSTR_16; + if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) { + bciPtr += offset; + } + Continue; + } + Case(i_UNPACK): + { + StgClosure* o = stgCast(StgClosure*,xStackPtr(0)); + const StgInfoTable* itbl = get_itbl(o); + int i = itbl->layout.payload.ptrs; + ASSERT( itbl->type == CONSTR + || itbl->type == CONSTR_STATIC + || itbl->type == CONSTR_NOCAF_STATIC + ); + while (--i>=0) { + xPushCPtr(payloadCPtr(o,i)); + } + Continue; + } + Case(i_VAR_big): + { + int n = BCO_INSTR_16; + StgPtr p = xStackPtr(n); + xPushPtr(p); + Continue; + } + Case(i_VAR): + { + StgPtr p = xStackPtr(BCO_INSTR_8); + xPushPtr(p); + Continue; + } + Case(i_CONST): + { + xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8))); + Continue; + } + Case(i_CONST_big): + { + int n = BCO_INSTR_16; + xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n))); + Continue; + } + Case(i_VOID): + { + SSS; PushTaggedRealWorld(); LLL; + Continue; + } + Case(i_VAR_INT): + { + StgInt i = xTaggedStackInt(BCO_INSTR_8); + xPushTaggedInt(i); + Continue; + } + Case(i_CONST_INT): + { + xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8)); + Continue; + } + Case(i_PACK_INT): + { + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL; + SET_HDR(o,&Izh_con_info,??); + payloadWord(o,0) = xPopTaggedInt(); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_UNPACK_INT): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + /* ASSERT(isIntLike(con)); */ + xPushTaggedInt(payloadWord(con,0)); + Continue; + } + Case(i_TEST_INT): + { + StgWord offset = BCO_INSTR_16; + StgInt x = xPopTaggedInt(); + StgInt y = xPopTaggedInt(); + if (x != y) { + bciPtr += offset; + } + Continue; + } + Case(i_CONST_INTEGER): + { + StgPtr p; + int n; + char* s = bcoConstAddr(bco,BCO_INSTR_8); + SSS; + n = size_fromStr(s); + p = CreateByteArrayToHoldInteger(n); + do_fromStr ( s, n, IntegerInsideByteArray(p)); + SloppifyIntegerEnd(p); + LLL; + xPushPtr(p); + Continue; + } + Case(i_VAR_WORD): + { + StgWord w = xTaggedStackWord(BCO_INSTR_8); + xPushTaggedWord(w); + Continue; + } + Case(i_CONST_WORD): + { + xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8)); + Continue; + } + Case(i_PACK_WORD): + { + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL; + SET_HDR(o,&Wzh_con_info,??); + payloadWord(o,0) = xPopTaggedWord(); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_UNPACK_WORD): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + /* ASSERT(isWordLike(con)); */ + xPushTaggedWord(payloadWord(con,0)); + Continue; + } + Case(i_VAR_ADDR): + { + StgAddr a = xTaggedStackAddr(BCO_INSTR_8); + xPushTaggedAddr(a); + Continue; + } + Case(i_CONST_ADDR): + { + xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8)); + Continue; + } + Case(i_PACK_ADDR): + { + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL; + SET_HDR(o,&Azh_con_info,??); + payloadPtr(o,0) = xPopTaggedAddr(); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_UNPACK_ADDR): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + /* ASSERT(isAddrLike(con)); */ + xPushTaggedAddr(payloadPtr(con,0)); + Continue; + } + Case(i_VAR_CHAR): + { + StgChar c = xTaggedStackChar(BCO_INSTR_8); + xPushTaggedChar(c); + Continue; + } + Case(i_CONST_CHAR): + { + xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8)); + Continue; + } + Case(i_PACK_CHAR): + { + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL; + SET_HDR(o,&Czh_con_info,??); + payloadWord(o,0) = xPopTaggedChar(); + xPushPtr(stgCast(StgPtr,o)); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + Continue; + } + Case(i_UNPACK_CHAR): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + /* ASSERT(isCharLike(con)); */ + xPushTaggedChar(payloadWord(con,0)); + Continue; + } + Case(i_VAR_FLOAT): + { + StgFloat f = xTaggedStackFloat(BCO_INSTR_8); + xPushTaggedFloat(f); + Continue; + } + Case(i_CONST_FLOAT): + { + xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8)); + Continue; + } + Case(i_PACK_FLOAT): + { + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL; + SET_HDR(o,&Fzh_con_info,??); + ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat()); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_UNPACK_FLOAT): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + /* ASSERT(isFloatLike(con)); */ + xPushTaggedFloat(PK_FLT(&payloadWord(con,0))); + Continue; + } + Case(i_VAR_DOUBLE): + { + StgDouble d = xTaggedStackDouble(BCO_INSTR_8); + xPushTaggedDouble(d); + Continue; + } + Case(i_CONST_DOUBLE): + { + xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8)); + Continue; + } + Case(i_CONST_DOUBLE_big): + { + int n = BCO_INSTR_16; + xPushTaggedDouble(bcoConstDouble(bco,n)); + Continue; + } + Case(i_PACK_DOUBLE): + { + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL; + SET_HDR(o,&Dzh_con_info,??); + ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble()); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj(stgCast(StgClosure*,o)); + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_UNPACK_DOUBLE): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + /* ASSERT(isDoubleLike(con)); */ + xPushTaggedDouble(PK_DBL(&payloadWord(con,0))); + Continue; + } + Case(i_VAR_STABLE): + { + fprintf(stderr, "unimp: i_VAR_STABLE\n" ); exit(0); + /*fix side effects here ...*/ + /* + xPushTaggedStablePtr(xTaggedStackStable(BCO_INSTR_8)); + */ + Continue; + } + Case(i_PACK_STABLE): + { + //StgClosure* o; + fprintf(stderr, "unimp: i_PACK_STABLE\n" ); exit(0); + /* + SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL; + SET_HDR(o,&StablePtr_con_info,??); + payloadWord(o,0) = xPopTaggedStablePtr(); + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj(stgCast(StgClosure*,o)); + ); + xPushPtr(stgCast(StgPtr,o)); + */ + Continue; + } + Case(i_UNPACK_STABLE): + { + //StgClosure* con; + fprintf(stderr, "unimp: i_UNPACK_STABLE\n" ); exit(0); + /* + con = stgCast(StgClosure*,xStackPtr(0)); + ASSERT(isStableLike(con)); + xPushTaggedStablePtr(payloadWord(con,0)); + */ + Continue; + } + Case(i_PRIMOP1): + { + int i; + void* p; + i = BCO_INSTR_8; + SSS; p = enterBCO_primop1 ( i ); LLL; + if (p) { obj = p; goto enterLoop; }; + Continue; + } + Case(i_PRIMOP2): + { + int i, trc; + void* p; + trc = 12345678; /* Hope that no StgThreadReturnCode has this value */ + i = BCO_INSTR_8; + SSS; p = enterBCO_primop2 ( i, &trc ); LLL; + if (p) { + if (trc == 12345678) { + /* we want to enter p */ + obj = p; goto enterLoop; + } else { + /* p is the the StgThreadReturnCode for this thread */ + RETURN((StgThreadReturnCode)p); + }; + } + Continue; + } + + /* combined insns, created by peephole opt */ + Case(i_SE): + { + int x = BCO_INSTR_8; + int y = BCO_INSTR_8; + ASSERT(xSp+x+y <= stgCast(StgPtr,xSu)); + /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ + if (x == 1) { + obj = xPopCPtr(); + xSp += y; + goto enterLoop; + } else { + while(--x >= 0) { + xSetStackWord(x+y,xStackWord(x)); + } + xSp += y; + obj = xPopCPtr(); + } + goto enterLoop; + } + Case(i_VV): + { + StgPtr p; + p = xStackPtr(BCO_INSTR_8); + xPushPtr(p); + p = xStackPtr(BCO_INSTR_8); + xPushPtr(p); + Continue; + } + Case(i_RV): + { + StgPtr p; + xPushPtr(bcoConstPtr(bco,BCO_INSTR_8)); + xPushPtr(stgCast(StgPtr,&ret_bco_info)); + p = xStackPtr(BCO_INSTR_8); + xPushPtr(p); + Continue; + } + Case(i_RVE): + { + StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8); + StgPtr ptr = xStackPtr(BCO_INSTR_8); + + /* A shortcut. We're going to push the address of a + return continuation, and then enter a variable, so + that when the var is evaluated, we return to the + continuation. The shortcut is: if the var is a + constructor, don't bother to enter it. Instead, + push the variable on the stack (since this is what + the continuation expects) and jump directly to the + continuation. + */ + if (get_itbl((StgClosure*)ptr)->type == CONSTR) { + xPushPtr(ptr); + obj = (StgClosure*)retaddr; + IF_DEBUG(evaluator, + fprintf(stderr, "object to enter is a constructor -- " + "jumping directly to return continuation\n" ); + ) + goto bco_entry; + } + + /* This is the normal, non-short-cut route */ + xPushPtr(retaddr); + xPushPtr(stgCast(StgPtr,&ret_bco_info)); + obj = (StgClosure*)ptr; + goto enterLoop; + } -static inline StgClosure* raiseAnError ( StgClosure* errObj ); -static inline void PopUpdateFrame( StgClosure* obj ) -{ - /* NB: doesn't assume that Sp == Su */ - IF_DEBUG(evaluator, - fprintf(stderr, "Updating "); - printPtr(stgCast(StgPtr,Su->updatee)); - fprintf(stderr, " with "); - printObj(obj); - fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su); - ); -#ifndef LAZY_BLACKHOLING - ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE - || get_itbl(Su->updatee)->type == CAF_BLACKHOLE - ); -#endif /* LAZY_BLACKHOLING */ - UPD_IND(Su->updatee,obj); - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame); - Su = Su->link; -} + Case(i_VAR_DOUBLE_big): + Case(i_CONST_FLOAT_big): + Case(i_VAR_FLOAT_big): + Case(i_CONST_CHAR_big): + Case(i_VAR_CHAR_big): + Case(i_CONST_ADDR_big): + Case(i_VAR_ADDR_big): + Case(i_CONST_INTEGER_big): + Case(i_CONST_INT_big): + Case(i_VAR_INT_big): + Case(i_VAR_WORD_big): + Case(i_RETADDR_big): + Case(i_ALLOC_PAP): + bciPtr--; + printf ( "\n\n" ); + disInstr ( bco, PC ); + barf("\nUnrecognised instruction"); + + EndDispatch + + barf("enterBCO: ran off end of loop"); + break; + } -static inline void PopStopFrame( StgClosure* obj ) -{ - /* Move Su just off the end of the stack, we're about to spam the - * STOP_FRAME with the return value. - */ - Su = stgCast(StgUpdateFrame*,Sp+1); - *stgCast(StgClosure**,Sp) = obj; -} +# undef LoopTopLabel +# undef Case +# undef Continue +# undef Dispatch +# undef EndDispatch -static inline void PushCatchFrame( StgClosure* handler ) -{ - StgCatchFrame* fp; - /* ToDo: stack check! */ - Sp -= sizeofW(StgCatchFrame); - fp = stgCast(StgCatchFrame*,Sp); - SET_HDR(fp,&catch_frame_info,CCCS); - fp->handler = handler; - fp->link = Su; - Su = stgCast(StgUpdateFrame*,fp); -} + /* ---------------------------------------------------- */ + /* End of the bytecode evaluator */ + /* ---------------------------------------------------- */ -static inline void PopCatchFrame( void ) -{ - /* NB: doesn't assume that Sp == Su */ - /* fprintf(stderr,"Popping catch frame\n"); */ + case CAF_UNENTERED: + { + StgBlockingQueue* bh; + StgCAF* caf = (StgCAF*)obj; + if (xSp - sizeofW(StgUpdateFrame) < xSpLim) { + xPushCPtr(obj); /* code to restart with */ + RETURN(StackOverflow); + } + /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME + and insert an indirection immediately */ + SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL; + SET_INFO(bh,&CAF_BLACKHOLE_info); + bh->blocking_queue = EndTSOQueue; + IF_DEBUG(gccafs, + fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf)); + SET_INFO(caf,&CAF_ENTERED_info); + caf->value = (StgClosure*)bh; + if (caf->mut_link == NULL) { + SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL; + } + SSS; PUSH_UPD_FRAME(bh,0); LLL; + xSp -= sizeofW(StgUpdateFrame); + caf->link = enteredCAFs; + enteredCAFs = caf; + obj = caf->body; + goto enterLoop; + } + case CAF_ENTERED: + { + StgCAF* caf = (StgCAF*)obj; + obj = caf->value; /* it's just a fancy indirection */ + goto enterLoop; + } + case BLACKHOLE: + case CAF_BLACKHOLE: + { + /*was StgBlackHole* */ + StgBlockingQueue* bh = (StgBlockingQueue*)obj; + /* Put ourselves on the blocking queue for this black hole and block */ + CurrentTSO->link = bh->blocking_queue; + bh->blocking_queue = CurrentTSO; + xPushCPtr(obj); /* code to restart with */ + barf("enter: CAF_BLACKHOLE unexpected!"); + RETURN(ThreadBlocked); + } + case AP_UPD: + { + StgAP_UPD* ap = stgCast(StgAP_UPD*,obj); + int i = ap->n_args; + if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) { + xPushCPtr(obj); /* code to restart with */ + RETURN(StackOverflow); + } + /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME + and insert an indirection immediately */ + SSS; PUSH_UPD_FRAME(ap,0); LLL; + xSp -= sizeofW(StgUpdateFrame); + while (--i >= 0) { + xPushWord(payloadWord(ap,i)); + } + obj = ap->fun; +#ifndef LAZY_BLACKHOLING +#error no no no + { + /* superfluous - but makes debugging easier */ + StgBlackHole* bh = stgCast(StgBlackHole*,ap); + SET_INFO(bh,&BLACKHOLE_info); + bh->blocking_queue = EndTSOQueue; + IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); + /*printObj(bh); */ + } +#endif /* LAZY_BLACKHOLING */ + goto enterLoop; + } + case PAP: + { + StgPAP* pap = stgCast(StgPAP*,obj); + int i = pap->n_args; /* ToDo: stack check */ + /* ToDo: if PAP is in whnf, we can update any update frames + * on top of stack. + */ + while (--i >= 0) { + xPushWord(payloadWord(pap,i)); + } + obj = pap->fun; + goto enterLoop; + } + case IND: + { + obj = stgCast(StgInd*,obj)->indirectee; + goto enterLoop; + } + case IND_OLDGEN: + { + obj = stgCast(StgIndOldGen*,obj)->indirectee; + goto enterLoop; + } + case CONSTR: + case CONSTR_INTLIKE: + case CONSTR_CHARLIKE: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + { + while (1) { + switch (get_itbl(stgCast(StgClosure*,xSp))->type) { + case CATCH_FRAME: + SSS; PopCatchFrame(); LLL; + break; + case UPDATE_FRAME: + xPopUpdateFrame(obj); + break; + case SEQ_FRAME: + SSS; PopSeqFrame(); LLL; + break; + case STOP_FRAME: + { + ASSERT(xSp==(P_)xSu); + IF_DEBUG(evaluator, + SSS; + printObj(obj); + /*fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);*/ + /*printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);*/ + LLL; + ); + SSS; PopStopFrame(obj); LLL; + RETURN(ThreadFinished); + } + case RET_BCO: + { + StgClosure* ret; + (void)xPopPtr(); + ret = xPopCPtr(); + xPushPtr((P_)obj); + obj = ret; + goto bco_entry; + /* was: goto enterLoop; + But we know that obj must be a bco now, so jump directly. + */ + } + case RET_SMALL: /* return to GHC */ + case RET_VEC_SMALL: + case RET_BIG: + case RET_VEC_BIG: + barf("todo: RET_[VEC_]{BIG,SMALL}"); + default: + belch("entered CONSTR with invalid continuation on stack"); + IF_DEBUG(evaluator, + SSS; + printObj(stgCast(StgClosure*,xSp)); + LLL; + ); + barf("bailing out"); + } + } + } + default: + { + SSS; + fprintf(stderr, "enterCountI = %d\n", enterCountI); + fprintf(stderr, "panic: enter: entered unknown closure\n"); + printObj(obj); + fprintf(stderr, "what it points at is\n"); + printObj( ((StgEvacuated*)obj) ->evacuee); + LLL; + exit(1); + /* formerly ... */ + CurrentTSO->whatNext = ThreadEnterGHC; + xPushCPtr(obj); /* code to restart with */ + RETURN(ThreadYielding); + } + } + barf("Ran off the end of enter - yoiks"); + assert(0); +} + +#undef RETURN +#undef BCO_INSTR_8 +#undef BCO_INSTR_16 +#undef SSS +#undef LLL +#undef PC +#undef xPushPtr +#undef xPopPtr +#undef xPushCPtr +#undef xPopCPtr +#undef xPopWord +#undef xStackPtr +#undef xStackWord +#undef xSetStackWord +#undef xPushTag +#undef xPopTag +#undef xPushTaggedInt +#undef xPopTaggedInt +#undef xTaggedStackInt +#undef xPushTaggedWord +#undef xPopTaggedWord +#undef xTaggedStackWord +#undef xPushTaggedAddr +#undef xTaggedStackAddr +#undef xPopTaggedAddr +#undef xPushTaggedChar +#undef xTaggedStackChar +#undef xPopTaggedChar +#undef xPushTaggedFloat +#undef xTaggedStackFloat +#undef xPopTaggedFloat +#undef xPushTaggedDouble +#undef xTaggedStackDouble +#undef xPopTaggedDouble + + + +/* -------------------------------------------------------------------------- + * Supporting routines for primops + * ------------------------------------------------------------------------*/ + +static inline void PushTag ( StackTag t ) + { *(--Sp) = t; } +static inline void PushPtr ( StgPtr x ) + { *(--stgCast(StgPtr*,Sp)) = x; } +static inline void PushCPtr ( StgClosure* x ) + { *(--stgCast(StgClosure**,Sp)) = x; } +static inline void PushInt ( StgInt x ) + { *(--stgCast(StgInt*,Sp)) = x; } +static inline void PushWord ( StgWord x ) + { *(--stgCast(StgWord*,Sp)) = x; } + + +static inline void checkTag ( StackTag t1, StackTag t2 ) + { ASSERT(t1 == t2);} +static inline void PopTag ( StackTag t ) + { checkTag(t,*(Sp++)); } +static inline StgPtr PopPtr ( void ) + { return *stgCast(StgPtr*,Sp)++; } +static inline StgClosure* PopCPtr ( void ) + { return *stgCast(StgClosure**,Sp)++; } +static inline StgInt PopInt ( void ) + { return *stgCast(StgInt*,Sp)++; } +static inline StgWord PopWord ( void ) + { return *stgCast(StgWord*,Sp)++; } + +static inline StgPtr stackPtr ( StgStackOffset i ) + { return *stgCast(StgPtr*, Sp+i); } +static inline StgInt stackInt ( StgStackOffset i ) + { return *stgCast(StgInt*, Sp+i); } +static inline StgWord stackWord ( StgStackOffset i ) + { return *stgCast(StgWord*,Sp+i); } + +static inline void setStackWord ( StgStackOffset i, StgWord w ) + { Sp[i] = w; } + +static inline void PushTaggedRealWorld( void ) + { PushTag(REALWORLD_TAG); } + inline void PushTaggedInt ( StgInt x ) + { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); } +static inline void PushTaggedWord ( StgWord x ) + { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } +static inline void PushTaggedAddr ( StgAddr x ) + { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } +static inline void PushTaggedChar ( StgChar x ) + { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); } +static inline void PushTaggedFloat ( StgFloat x ) + { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); } +static inline void PushTaggedDouble ( StgDouble x ) + { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); } +static inline void PushTaggedStablePtr ( StgStablePtr x ) + { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); } +static inline void PushTaggedBool ( int x ) + { PushTaggedInt(x); } + + + +static inline void PopTaggedRealWorld ( void ) + { PopTag(REALWORLD_TAG); } + inline StgInt PopTaggedInt ( void ) + { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); + Sp += sizeofW(StgInt); return r;} +static inline StgWord PopTaggedWord ( void ) + { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); + Sp += sizeofW(StgWord); return r;} +static inline StgAddr PopTaggedAddr ( void ) + { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); + Sp += sizeofW(StgAddr); return r;} +static inline StgChar PopTaggedChar ( void ) + { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); + Sp += sizeofW(StgChar); return r;} +static inline StgFloat PopTaggedFloat ( void ) + { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); + Sp += sizeofW(StgFloat); return r;} +static inline StgDouble PopTaggedDouble ( void ) + { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); + Sp += sizeofW(StgDouble); return r;} +static inline StgStablePtr PopTaggedStablePtr ( void ) + { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); + Sp += sizeofW(StgStablePtr); return r;} + + + +static inline StgInt taggedStackInt ( StgStackOffset i ) + { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); } +static inline StgWord taggedStackWord ( StgStackOffset i ) + { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); } +static inline StgAddr taggedStackAddr ( StgStackOffset i ) + { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); } +static inline StgChar taggedStackChar ( StgStackOffset i ) + { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; } +static inline StgFloat taggedStackFloat ( StgStackOffset i ) + { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); } +static inline StgDouble taggedStackDouble ( StgStackOffset i ) + { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); } +static inline StgStablePtr taggedStackStable ( StgStackOffset i ) + { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); } + + +/* -------------------------------------------------------------------------- + * Heap allocation + * + * Should we allocate from a nursery or use the + * doYouWantToGC/allocate interface? We'd already implemented a + * nursery-style scheme when the doYouWantToGC/allocate interface + * was implemented. + * One reason to prefer the doYouWantToGC/allocate interface is to + * support operations which allocate an unknown amount in the heap + * (array ops, gmp ops, etc) + * ------------------------------------------------------------------------*/ + +static inline StgPtr grabHpUpd( nat size ) +{ + ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); +#if CRUDE_PROFILING + cp_bill_words ( size ); +#endif + return allocate(size); +} + +static inline StgPtr grabHpNonUpd( nat size ) +{ + ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); +#if CRUDE_PROFILING + cp_bill_words ( size ); +#endif + return allocate(size); +} + +/* -------------------------------------------------------------------------- + * Manipulate "update frame" list: + * o Update frames (based on stg_do_update and friends in Updates.hc) + * o Error handling/catching (based on catchzh_fast and friends in Prims.hc) + * o Seq frames (based on seq_frame_entry in Prims.hc) + * o Stop frames + * ------------------------------------------------------------------------*/ + +static inline void PopUpdateFrame( StgClosure* obj ) +{ + /* NB: doesn't assume that Sp == Su */ + IF_DEBUG(evaluator, + fprintf(stderr, "Updating "); + printPtr(stgCast(StgPtr,Su->updatee)); + fprintf(stderr, " with "); + printObj(obj); + fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su); + ); +#ifndef LAZY_BLACKHOLING + ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE + || get_itbl(Su->updatee)->type == CAF_BLACKHOLE + ); +#endif /* LAZY_BLACKHOLING */ + UPD_IND(Su->updatee,obj); + Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame); + Su = Su->link; +} + +static inline void PopStopFrame( StgClosure* obj ) +{ + /* Move Su just off the end of the stack, we're about to spam the + * STOP_FRAME with the return value. + */ + Su = stgCast(StgUpdateFrame*,Sp+1); + *stgCast(StgClosure**,Sp) = obj; +} + +static inline void PushCatchFrame( StgClosure* handler ) +{ + StgCatchFrame* fp; + /* ToDo: stack check! */ + Sp -= sizeofW(StgCatchFrame); + fp = stgCast(StgCatchFrame*,Sp); + SET_HDR(fp,&catch_frame_info,CCCS); + fp->handler = handler; + fp->link = Su; + Su = stgCast(StgUpdateFrame*,fp); +} + +static inline void PopCatchFrame( void ) +{ + /* NB: doesn't assume that Sp == Su */ + /* fprintf(stderr,"Popping catch frame\n"); */ Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame); Su = stgCast(StgCatchFrame*,Su)->link; } @@ -577,7 +1831,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); PushTaggedDouble(e); \ } -#ifdef PROVIDE_WORD #define OP_WW_B(e) \ { \ StgWord x = PopTaggedWord(); \ @@ -603,9 +1856,7 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); StgWord x = PopTaggedWord(); \ PushTaggedWord(e); \ } -#endif -#ifdef PROVIDE_ADDR #define OP_AA_B(e) \ { \ StgAddr x = PopTaggedAddr(); \ @@ -633,14 +1884,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); s; \ PushTaggedInt(r); \ } -#define OP_AI_z(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgInt64 r; \ - s; \ - PushTaggedInt64(r); \ -} #define OP_AI_A(s) \ { \ StgAddr x = PopTaggedAddr(); \ @@ -687,13 +1930,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); StgInt z = PopTaggedInt(); \ s; \ } -#define OP_AIz_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgInt64 z = PopTaggedInt64(); \ - s; \ -} #define OP_AIA_(s) \ { \ StgAddr x = PopTaggedAddr(); \ @@ -723,7 +1959,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); s; \ } -#endif /* PROVIDE_ADDR */ #define OP_FF_B(e) \ { \ @@ -801,231 +2036,86 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); PushTaggedFloat(e); \ } -#ifdef PROVIDE_INT64 -#define OP_zI_F(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - int y = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} -#define OP_zI_D(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - int y = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} -#define OP_zz_I(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedInt(e); \ -} -#define OP_z_z(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedInt64(e); \ -} -#define OP_zz_z(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedInt64(e); \ -} -#define OP_zW_z(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedInt64(e); \ -} -#define OP_zz_zZ(e1,e2) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedInt64(e1); \ - PushTaggedInt64(e2); \ -} -#define OP_zz_B(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedBool(e); \ -} -#define OP__z(e) \ -{ \ - PushTaggedInt64(e); \ -} -#define OP_z_I(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedInt(e); \ -} -#define OP_I_z(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedInt64(e); \ -} -#ifdef PROVIDE_WORD -#define OP_z_W(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedWord(e); \ -} -#define OP_W_z(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedInt64(e); \ -} + +#ifdef STANDALONE_INTEGER +StgPtr CreateByteArrayToHoldInteger ( int nbytes ) +{ + StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_); + StgWord size = sizeofW(StgArrWords) + words; + StgArrWords* arr = (StgArrWords*)allocate(size); + SET_HDR(arr,&ARR_WORDS_info,CCCS); + arr->words = words; + ASSERT(nbytes <= arr->words * sizeof(W_)); +#ifdef DEBUG + {nat i; + for (i = 0; i < words; ++i) { + arr->payload[i] = 0xdeadbeef; + }} + { B* b = (B*) &(arr->payload[0]); + b->used = b->sign = 0; + } #endif -#define OP_z_F(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - printf("%lld = %f\n",x,(float)(e)); \ - PushTaggedFloat(e); \ -} -#define OP_F_z(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedInt64(e); \ -} -#define OP_z_D(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedDouble(e); \ -} -#define OP_D_z(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedInt64(e); \ + return (StgPtr)arr; } -#endif -#ifdef PROVIDE_INTEGER - -#define OP_ZI_F(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - int y = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} -#define OP_F_ZI(s) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - mpz_ptr r1 = mpz_alloc(); \ - StgInt r2; \ - s; \ - PushTaggedInt(r2); \ - PushTaggedInteger(r1); \ -} -#define OP_ZI_D(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - int y = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} -#define OP_D_ZI(s) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - mpz_ptr r1 = mpz_alloc(); \ - StgInt r2; \ - s; \ - PushTaggedInt(r2); \ - PushTaggedInteger(r1); \ -} -#define OP_Z_Z(s) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#define OP_ZZ_Z(s) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - mpz_ptr y = PopTaggedInteger(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#define OP_ZZ_B(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - mpz_ptr y = PopTaggedInteger(); \ - PushTaggedBool(e); \ +B* IntegerInsideByteArray ( StgPtr arr0 ) +{ + B* b; + StgArrWords* arr = (StgArrWords*)arr0; + ASSERT(GET_INFO(arr) == &ARR_WORDS_info); + b = (B*) &(arr->payload[0]); + return b; } -#define OP_Z_I(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedInt(e); \ -} -#define OP_I_Z(s) \ -{ \ - StgInt x = PopTaggedInt(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#ifdef PROVIDE_INT64 -#define OP_Z_z(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedInt64(e); \ -} -#define OP_z_Z(s) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ + +void SloppifyIntegerEnd ( StgPtr arr0 ) +{ + StgArrWords* arr = (StgArrWords*)arr0; + B* b = (B*) & (arr->payload[0]); + I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_); + if (nwunused >= ((I_)sizeofW(StgArrWords))) { + StgArrWords* slop; + b->size -= nwunused * sizeof(W_); + if (b->size < b->used) b->size = b->used; + do_renormalise(b); + ASSERT(is_sane(b)); + arr->words -= nwunused; + slop = &(arr->payload[arr->words]); + SET_HDR(slop,&ARR_WORDS_info,CCCS); + slop->words = nwunused - sizeofW(StgArrWords); + ASSERT( &(slop->payload[slop->words]) == + &(arr->payload[arr->words + nwunused]) ); + } } -#endif -#ifdef PROVIDE_WORD -#define OP_Z_W(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedWord(e); \ -} -#define OP_W_Z(s) \ -{ \ - StgWord x = PopTaggedWord(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ + +#define OP_Z_Z(op) \ +{ \ + B* x = IntegerInsideByteArray(PopPtr()); \ + int n = mycat2(size_,op)(x); \ + StgPtr p = CreateByteArrayToHoldInteger(n); \ + mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \ + SloppifyIntegerEnd(p); \ + PushPtr(p); \ +} +#define OP_ZZ_Z(op) \ +{ \ + B* x = IntegerInsideByteArray(PopPtr()); \ + B* y = IntegerInsideByteArray(PopPtr()); \ + int n = mycat2(size_,op)(x,y); \ + StgPtr p = CreateByteArrayToHoldInteger(n); \ + mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \ + SloppifyIntegerEnd(p); \ + PushPtr(p); \ } #endif -#define OP_Z_F(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedFloat(e); \ -} -#define OP_F_Z(s) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#define OP_Z_D(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedDouble(e); \ -} -#define OP_D_Z(s) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} - -#endif /* ifdef PROVIDE_INTEGER */ - -#ifdef PROVIDE_ARRAY + + + + #define HEADER_mI(ty,where) \ StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \ nat i = PopTaggedInt(); \ if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \ - obj = raiseIndex(where); \ - goto enterLoop; \ + return (raiseIndex(where)); \ } #define OP_mI_ty(ty,where,s) \ { \ @@ -1044,14 +2134,11 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); } \ } -#endif /* PROVIDE_ARRAY */ - -static int enterCountI = 0; void myStackCheck ( void ) { - StgPtr sp = Sp; - StgPtr su = Su; + //StgPtr sp = (StgPtr)Sp; + StgPtr su = (StgPtr)Su; //fprintf(stderr, "myStackCheck\n"); if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) { fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" ); @@ -1064,13 +2151,13 @@ void myStackCheck ( void ) } switch (get_itbl(stgCast(StgClosure*,su))->type) { case CATCH_FRAME: - su = ((StgCatchFrame*)(su))->link; + su = (StgPtr) ((StgCatchFrame*)(su))->link; break; case UPDATE_FRAME: - su = ((StgUpdateFrame*)(su))->link; + su = (StgPtr) ((StgUpdateFrame*)(su))->link; break; case SEQ_FRAME: - su = ((StgSeqFrame*)(su))->link; + su = (StgPtr) ((StgSeqFrame*)(su))->link; break; case STOP_FRAME: goto postloop; @@ -1082,1431 +2169,730 @@ void myStackCheck ( void ) } -/* This is written as one giant function in the hope that gcc will do - * a better job of register allocation. - */ -StgThreadReturnCode enter( StgClosure* obj ) +/* -------------------------------------------------------------------------- + * Primop stuff for bytecode interpreter + * ------------------------------------------------------------------------*/ + +/* Returns & of the next thing to enter (if throwing an exception), + or NULL in the normal case. +*/ +static void* enterBCO_primop1 ( int primop1code ) { - /* We use a char so that we'll do a context_switch check every 256 - * iterations. - */ - char enterCount = 0; - //fprintf ( stderr, "enter: Sp=%p Su=%p\n", Sp, Su); -enterLoop: - enterCountI++;// fprintf(stderr, "%d\n", enterCountI); - ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su)); - -#if DEBUG - IF_DEBUG(evaluator, - fprintf(stderr, - "\n---------------------------------------------------------------\n"); - fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj); - fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su); - fprintf(stderr, "\n" ); - printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su); - fprintf(stderr, "\n\n"); - ); -#endif - - if (++enterCount == 0 && context_switch) { - PushCPtr(obj); /* code to restart with */ - assert(0); - return ThreadYielding; - } - switch ( get_itbl(obj)->type ) { - case INVALID_OBJECT: - barf("Invalid object %p",obj); - case BCO: - { - StgBCO* bco = stgCast(StgBCO*,obj); - InstrPtr pc = 0; - - if (doYouWantToGC()) { - PushCPtr(obj); /* code to restart with */ - return HeapOverflow; + switch (primop1code) { + case i_pushseqframe: + { + StgClosure* c = PopCPtr(); + PushSeqFrame(); + PushCPtr(c); + break; + } + case i_pushcatchframe: + { + StgClosure* e = PopCPtr(); + StgClosure* h = PopCPtr(); + PushCatchFrame(h); + PushCPtr(e); + break; } - while (1) { - ASSERT(pc < bco->n_instrs); - IF_DEBUG(evaluator, - fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc); - disInstr(bco,pc); - /*fprintf(stderr,"\t"); printStackObj(Sp); */ - fprintf(stderr,"\n"); - ); - switch (bcoInstr(bco,pc++)) { - case i_INTERNAL_ERROR: - barf("INTERNAL_ERROR at %p:%d",bco,pc-1); - case i_PANIC: - barf("PANIC at %p:%d",bco,pc-1); - case i_STK_CHECK: - { - int n = bcoInstr(bco,pc++); - if (Sp - n < SpLim) { - PushCPtr(obj); /* code to restart with */ - return StackOverflow; - } - break; - } - case i_ARG_CHECK: - { - /* ToDo: make sure that hp check allows for possible PAP */ - nat n = bcoInstr(bco,pc++); - if (stgCast(StgPtr,Sp + n) > stgCast(StgPtr,Su)) { - StgWord words = (P_)Su - Sp; - - /* first build a PAP */ - ASSERT((P_)Su >= Sp); /* was (words >= 0) but that's always true */ - if (words == 0) { /* optimisation */ - /* Skip building the PAP and update with an indirection. */ - } else { /* Build the PAP. */ - /* In the evaluator, we avoid the need to do - * a heap check here by including the size of - * the PAP in the heap check we performed - * when we entered the BCO. - */ - StgInt i; - StgPAP* pap = stgCast(StgPAP*,grabHpNonUpd(PAP_sizeW(words))); - SET_HDR(pap,&PAP_info,CC_pap); - pap->n_args = words; - pap->fun = obj; - for(i = 0; i < (I_)words; ++i) { - payloadWord(pap,i) = Sp[i]; - } - Sp += words; - obj = stgCast(StgClosure*,pap); - } - - /* now deal with "update frame" */ - /* as an optimisation, we process all on top of stack */ - /* instead of just the top one */ - ASSERT(Sp==(P_)Su); - do { - switch (get_itbl(Su)->type) { - case CATCH_FRAME: - PopCatchFrame(); - ASSERT(Sp != (P_)Su); - /* We hit a CATCH frame during an arg satisfaction - * check. So now return to bco_info which is under - * the CATCH frame. The following code is copied - * from a case RET_BCO further down. - * (The reason why we're here is that something of - * functional type has been evaluated as a possibly - * exception-throwing computation, but has not thrown - * any exception, and is now returning to the - * algebraic-case-continuation which forced the - * evaluation in the first place.) - */ - { - StgClosure* ret; - PopPtr(); - ret = PopCPtr(); - PushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - break; - - break; - case UPDATE_FRAME: - PopUpdateFrame(obj); - break; - case STOP_FRAME: - PopStopFrame(obj); - return ThreadFinished; - case SEQ_FRAME: - PopSeqFrame(); - ASSERT(Sp != (P_)Su); - /* We hit a SEQ frame during an arg satisfaction check. - * So now return to bco_info which is under the - * SEQ frame. The following code is copied from a - * case RET_BCO further down. (The reason why we're - * here is that something of functional type has - * been seq-d on, and we're now returning to the - * algebraic-case-continuation which forced the - * evaluation in the first place.) - */ - { - StgClosure* ret; - PopPtr(); - ret = PopCPtr(); - PushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - break; - default: - barf("Invalid update frame during argcheck"); - } - } while (Sp==(P_)Su); - goto enterLoop; - } - break; - } - case i_ALLOC_AP: - { - int words = bcoInstr(bco,pc++); - PushPtr(grabHpUpd(AP_sizeW(words))); - break; - } - case i_ALLOC_CONSTR: - { - StgInfoTable* info = bcoConstAddr(bco,bcoInstr(bco,pc++)); - StgClosure* c = stgCast(StgClosure*,grabHpNonUpd(sizeW_fromITBL(info))); - SET_HDR(c,info,??); - PushPtr(stgCast(StgPtr,c)); - break; - } - case i_MKAP: - { - int x = bcoInstr(bco,pc++); /* ToDo: Word not Int! */ - int y = bcoInstr(bco,pc++); - StgAP_UPD* o = stgCast(StgAP_UPD*,stackPtr(x)); - SET_HDR(o,&AP_UPD_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,PopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = PopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_MKAP_big: - { - int x, y; - StgAP_UPD* o; - x = bcoInstr16(bco,pc); pc += 2; /* ToDo: Word not Int! */ - y = bcoInstr16(bco,pc); pc += 2; - o = stgCast(StgAP_UPD*,stackPtr(x)); - SET_HDR(o,&AP_UPD_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,PopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = PopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_MKPAP: - { - int x = bcoInstr(bco,pc++); - int y = bcoInstr(bco,pc++); - StgPAP* o = stgCast(StgPAP*,stackPtr(x)); - SET_HDR(o,&PAP_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,PopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = PopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_PACK: - { - int offset = bcoInstr(bco,pc++); - StgClosure* o = stgCast(StgClosure*,stackPtr(offset)); - const StgInfoTable* info = get_itbl(o); - nat p = info->layout.payload.ptrs; - nat np = info->layout.payload.nptrs; - nat i; - for(i=0; i < p; ++i) { - payloadCPtr(o,i) = PopCPtr(); - } - for(i=0; i < np; ++i) { - payloadWord(o,p+i) = 0xdeadbeef; - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_SLIDE: - { - int x = bcoInstr(bco,pc++); - int y = bcoInstr(bco,pc++); - ASSERT(Sp+x+y <= stgCast(StgPtr,Su)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - while(--x >= 0) { - setStackWord(x+y,stackWord(x)); - } - Sp += y; - break; - } - case i_SLIDE_big: - { - int x, y; - x = bcoInstr16(bco,pc); pc += 2; - y = bcoInstr16(bco,pc); pc += 2; - ASSERT(Sp+x+y <= stgCast(StgPtr,Su)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - while(--x >= 0) { - setStackWord(x+y,stackWord(x)); - } - Sp += y; - break; - } - case i_ENTER: - { - obj = PopCPtr(); - goto enterLoop; - } - case i_RETADDR: - { - PushPtr(bcoConstPtr(bco,bcoInstr(bco,pc++))); - PushPtr(stgCast(StgPtr,&ret_bco_info)); - break; - } - case i_TEST: - { - int tag = bcoInstr(bco,pc++); - StgWord offset = bcoInstr16(bco,pc); pc += 2; - if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) { - pc += offset; - } - break; - } - case i_UNPACK: - { - StgClosure* o = stgCast(StgClosure*,stackPtr(0)); - const StgInfoTable* itbl = get_itbl(o); - int i = itbl->layout.payload.ptrs; - ASSERT( itbl->type == CONSTR - || itbl->type == CONSTR_STATIC - || itbl->type == CONSTR_NOCAF_STATIC - ); - while (--i>=0) { - PushCPtr(payloadCPtr(o,i)); - } - break; - } - case i_VAR_big: - { - PushPtr(stackPtr(bcoInstr16(bco,pc))); pc+=2; - break; - } - case i_VAR: - { - PushPtr(stackPtr(bcoInstr(bco,pc++))); - break; - } - case i_CONST: - { - PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++)))); - break; - } - case i_CONST_big: - { - PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr16(bco,pc)))); pc += 2; - break; - } - case i_VOID: - { - PushTaggedRealWorld(); - break; - } - case i_VAR_INT: - { - PushTaggedInt(taggedStackInt(bcoInstr(bco,pc++))); - break; - } - case i_CONST_INT: - { - PushTaggedInt(bcoConstInt(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_INT: - { - ASSERT(0); - break; - } - case i_PACK_INT: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Izh_sizeW)); - SET_HDR(o,&Izh_con_info,??); - payloadWord(o,0) = PopTaggedInt(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_INT: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isIntLike(con)); */ - PushTaggedInt(payloadWord(con,0)); - break; - } - case i_TEST_INT: - { - StgWord offset = bcoInstr16(bco,pc); - StgInt x = PopTaggedInt(); - StgInt y = PopTaggedInt(); - pc += 2; - if (x != y) { - pc += offset; - } - break; - } -#ifdef PROVIDE_INT64 - case i_VAR_INT64: - { - PushTaggedInt64(taggedStackInt64(bcoInstr(bco,pc++))); - break; - } - case i_CONST_INT64: - { - PushTaggedInt64(bcoConstInt64(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_INT64: - { - ASSERT(0); /* ToDo(); */ - break; - } - case i_PACK_INT64: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64zh_sizeW)); - SET_HDR(o,&I64zh_con_info,??); - ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_INT64: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /*ASSERT(isInt64Like(con)); */ - PushTaggedInt64(PK_Int64(&payloadWord(con,0))); - break; - } -#endif -#ifdef PROVIDE_INTEGER - case i_CONST_INTEGER: - { - char* s = bcoConstAddr(bco,bcoInstr(bco,pc++)); - mpz_ptr r = mpz_alloc(); - if (s[0] == '0' && s[1] == 'x') { - mpz_set_str(r,s+2,16); - } else { - mpz_set_str(r,s,10); - } - PushTaggedInteger(r); - break; - } -#endif - -#ifdef PROVIDE_WORD - case i_VAR_WORD: - { - PushTaggedWord(taggedStackWord(bcoInstr(bco,pc++))); - break; - } - case i_CONST_WORD: - { - PushTaggedWord(bcoConstWord(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_WORD: - { - ASSERT(0); - break; - } - case i_PACK_WORD: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Wzh_sizeW)); - - SET_HDR(o,&Wzh_con_info,??); - payloadWord(o,0) = PopTaggedWord(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_WORD: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isWordLike(con)); */ - PushTaggedWord(payloadWord(con,0)); - break; - } -#endif -#ifdef PROVIDE_ADDR - case i_VAR_ADDR: - { - PushTaggedAddr(taggedStackAddr(bcoInstr(bco,pc++))); - break; - } - case i_CONST_ADDR: - { - PushTaggedAddr(bcoConstAddr(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_ADDR: - { - ASSERT(0); - break; - } - case i_PACK_ADDR: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Azh_sizeW)); - SET_HDR(o,&Azh_con_info,??); - payloadPtr(o,0) = PopTaggedAddr(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_ADDR: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isAddrLike(con)); */ - PushTaggedAddr(payloadPtr(con,0)); - break; - } -#endif - case i_VAR_CHAR: - { - PushTaggedChar(taggedStackChar(bcoInstr(bco,pc++))); - break; - } - case i_CONST_CHAR: - { - PushTaggedChar(bcoConstChar(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_CHAR: - { - ASSERT(0); - break; - } - case i_PACK_CHAR: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Czh_sizeW)); - SET_HDR(o,&Czh_con_info,??); - payloadWord(o,0) = PopTaggedChar(); - PushPtr(stgCast(StgPtr,o)); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_UNPACK_CHAR: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isCharLike(con)); */ - PushTaggedChar(payloadWord(con,0)); - break; - } - case i_VAR_FLOAT: - { - PushTaggedFloat(taggedStackFloat(bcoInstr(bco,pc++))); - break; - } - case i_CONST_FLOAT: - { - PushTaggedFloat(bcoConstFloat(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_FLOAT: - { - ASSERT(0); - break; - } - case i_PACK_FLOAT: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Fzh_sizeW)); - SET_HDR(o,&Fzh_con_info,??); - ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_FLOAT: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isFloatLike(con)); */ - PushTaggedFloat(PK_FLT(&payloadWord(con,0))); - break; - } - case i_VAR_DOUBLE: - { - PushTaggedDouble(taggedStackDouble(bcoInstr(bco,pc++))); - break; - } - case i_CONST_DOUBLE: - { - PushTaggedDouble(bcoConstDouble(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_DOUBLE: - { - ASSERT(0); - break; - } - case i_PACK_DOUBLE: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Dzh_sizeW)); - SET_HDR(o,&Dzh_con_info,??); - ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_DOUBLE: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isDoubleLike(con)); */ - PushTaggedDouble(PK_DBL(&payloadWord(con,0))); - break; - } -#ifdef PROVIDE_STABLE - case i_VAR_STABLE: - { - PushTaggedStablePtr(taggedStackStable(bcoInstr(bco,pc++))); - break; - } - case i_RETURN_STABLE: - { - ASSERT(0); - break; - } - case i_PACK_STABLE: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Stablezh_sizeW)); - SET_HDR(o,&StablePtr_con_info,??); - payloadWord(o,0) = PopTaggedStablePtr(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_STABLE: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isStableLike(con)); */ - PushTaggedStablePtr(payloadWord(con,0)); - break; - } -#endif - case i_PRIMOP1: - { - switch (bcoInstr(bco,pc++)) { - case i_INTERNAL_ERROR1: - barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1); - - case i_pushseqframe: - { - StgClosure* c = PopCPtr(); - PushSeqFrame(); - PushCPtr(c); - break; - } - case i_pushcatchframe: - { - StgClosure* e = PopCPtr(); - StgClosure* h = PopCPtr(); - PushCatchFrame(h); - PushCPtr(e); - break; - } - - case i_gtChar: OP_CC_B(x>y); break; - case i_geChar: OP_CC_B(x>=y); break; - case i_eqChar: OP_CC_B(x==y); break; - case i_neChar: OP_CC_B(x!=y); break; - case i_ltChar: OP_CC_B(xy); break; - case i_geInt: OP_II_B(x>=y); break; - case i_eqInt: OP_II_B(x==y); break; - case i_neInt: OP_II_B(x!=y); break; - case i_ltInt: OP_II_B(x>y); break; /* ToDo */ - case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */ - -#ifdef PROVIDE_INT64 - case i_gtInt64: OP_zz_B(x>y); break; - case i_geInt64: OP_zz_B(x>=y); break; - case i_eqInt64: OP_zz_B(x==y); break; - case i_neInt64: OP_zz_B(x!=y); break; - case i_ltInt64: OP_zz_B(xy); break; + case i_geChar: OP_CC_B(x>=y); break; + case i_eqChar: OP_CC_B(x==y); break; + case i_neChar: OP_CC_B(x!=y); break; + case i_ltChar: OP_CC_B(xy); break; + case i_geInt: OP_II_B(x>=y); break; + case i_eqInt: OP_II_B(x==y); break; + case i_neInt: OP_II_B(x!=y); break; + case i_ltInt: OP_II_B(x>y); break; /* ToDo */ - case i_shiftRLInt64: OP_zW_z(x>>y); break; /* ToDo */ - - case i_int64ToInt: OP_z_I(x); break; - case i_intToInt64: OP_I_z(x); break; -#ifdef PROVIDE_WORD - case i_int64ToWord: OP_z_W(x); break; - case i_wordToInt64: OP_W_z(x); break; -#endif - case i_int64ToFloat: OP_z_F(x); break; - case i_floatToInt64: OP_F_z(x); break; - case i_int64ToDouble: OP_z_D(x); break; - case i_doubleToInt64: OP_D_z(x); break; -#endif -#ifdef PROVIDE_WORD - case i_gtWord: OP_WW_B(x>y); break; - case i_geWord: OP_WW_B(x>=y); break; - case i_eqWord: OP_WW_B(x==y); break; - case i_neWord: OP_WW_B(x!=y); break; - case i_ltWord: OP_WW_B(x>y); break; /* ToDo */ - case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */ - case i_intToWord: OP_I_W(x); break; - case i_wordToInt: OP_W_I(x); break; -#endif -#ifdef PROVIDE_ADDR - case i_gtAddr: OP_AA_B(x>y); break; - case i_geAddr: OP_AA_B(x>=y); break; - case i_eqAddr: OP_AA_B(x==y); break; - case i_neAddr: OP_AA_B(x!=y); break; - case i_ltAddr: OP_AA_B(x>y); break; /* ToDo */ + case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */ + + case i_gtWord: OP_WW_B(x>y); break; + case i_geWord: OP_WW_B(x>=y); break; + case i_eqWord: OP_WW_B(x==y); break; + case i_neWord: OP_WW_B(x!=y); break; + case i_ltWord: OP_WW_B(x>y); break; /* ToDo */ + case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */ + case i_intToWord: OP_I_W(x); break; + case i_wordToInt: OP_W_I(x); break; + + case i_gtAddr: OP_AA_B(x>y); break; + case i_geAddr: OP_AA_B(x>=y); break; + case i_eqAddr: OP_AA_B(x==y); break; + case i_neAddr: OP_AA_B(x!=y); break; + case i_ltAddr: OP_AA_B(x0 ? 1 : 0)); - } - break; - case i_negateInteger: OP_Z_Z(mpz_neg(r,x)); break; - case i_plusInteger: OP_ZZ_Z(mpz_add(r,x,y)); break; - case i_minusInteger: OP_ZZ_Z(mpz_sub(r,x,y)); break; - case i_timesInteger: OP_ZZ_Z(mpz_mul(r,x,y)); break; - case i_quotRemInteger: - { - mpz_ptr x = PopTaggedInteger(); - mpz_ptr y = PopTaggedInteger(); - mpz_ptr q = mpz_alloc(); - mpz_ptr r = mpz_alloc(); - if (mpz_sgn(y) == 0) { - obj = raiseDiv0("quotRemInteger"); - goto enterLoop; - } - mpz_tdiv_qr(q,r,x,y); - PushTaggedInteger(r); /* last result */ - PushTaggedInteger(q); /* first result */ - } - break; - case i_divModInteger: - { - mpz_ptr x = PopTaggedInteger(); - mpz_ptr y = PopTaggedInteger(); - mpz_ptr q = mpz_alloc(); - mpz_ptr r = mpz_alloc(); - if (mpz_sgn(y) == 0) { - obj = raiseDiv0("divModInteger"); - goto enterLoop; - } - mpz_fdiv_qr(q,r,x,y); - PushTaggedInteger(r); /* last result */ - PushTaggedInteger(q); /* first result */ - } - break; - case i_integerToInt: OP_Z_I(mpz_get_si(x)); break; - case i_intToInteger: OP_I_Z(mpz_set_si(r,x)); break; -#ifdef PROVIDE_INT64 - case i_integerToInt64: OP_Z_z(mpz_get_si(x)); break; - case i_int64ToInteger: OP_z_Z(mpz_set_si(r,x)); break; -#endif -#ifdef PROVIDE_WORD - /* NB Use of mpz_get_si is quite deliberate since otherwise - * -255 is converted to 255. - */ - case i_integerToWord: OP_Z_W(mpz_get_si(x)); break; - case i_wordToInteger: OP_W_Z(mpz_set_ui(r,x)); break; -#endif - case i_integerToFloat: OP_Z_F(mpz_get_d(x)); break; - case i_floatToInteger: OP_F_Z(mpz_set_d(r,x)); break; - case i_integerToDouble: OP_Z_D(mpz_get_d(x)); break; - case i_doubleToInteger: OP_D_Z(mpz_set_d(r,x)); break; -#endif /* PROVIDE_INTEGER */ - - case i_gtFloat: OP_FF_B(x>y); break; - case i_geFloat: OP_FF_B(x>=y); break; - case i_eqFloat: OP_FF_B(x==y); break; - case i_neFloat: OP_FF_B(x!=y); break; - case i_ltFloat: OP_FF_B(x0 ? 1 : 0)); + } + break; + case i_negateInteger: OP_Z_Z(neg); break; + case i_plusInteger: OP_ZZ_Z(add); break; + case i_minusInteger: OP_ZZ_Z(sub); break; + case i_timesInteger: OP_ZZ_Z(mul); break; + case i_quotRemInteger: + { + B* x = IntegerInsideByteArray(PopPtr()); + B* y = IntegerInsideByteArray(PopPtr()); + int n = size_qrm(x,y); + StgPtr q = CreateByteArrayToHoldInteger(n); + StgPtr r = CreateByteArrayToHoldInteger(n); + if (do_getsign(y)==0) + return (raiseDiv0("quotRemInteger")); + do_qrm(x,y,n,IntegerInsideByteArray(q), + IntegerInsideByteArray(r)); + SloppifyIntegerEnd(q); + SloppifyIntegerEnd(r); + PushPtr(r); + PushPtr(q); + } + break; + case i_intToInteger: + { + int n = size_fromInt(); + StgPtr p = CreateByteArrayToHoldInteger(n); + do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p)); + PushPtr(p); + } + break; + case i_wordToInteger: + { + int n = size_fromWord(); + StgPtr p = CreateByteArrayToHoldInteger(n); + do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p)); + PushPtr(p); + } + break; + case i_integerToInt: PushTaggedInt(do_toInt( + IntegerInsideByteArray(PopPtr()) + )); + break; + + case i_integerToWord: PushTaggedWord(do_toWord( + IntegerInsideByteArray(PopPtr()) + )); + break; + + case i_integerToFloat: PushTaggedFloat(do_toFloat( + IntegerInsideByteArray(PopPtr()) + )); + break; + + case i_integerToDouble: PushTaggedDouble(do_toDouble( + IntegerInsideByteArray(PopPtr()) + )); + break; +#else +#error Non-standalone integer not yet implemented +#endif /* STANDALONE_INTEGER */ + + case i_gtFloat: OP_FF_B(x>y); break; + case i_geFloat: OP_FF_B(x>=y); break; + case i_eqFloat: OP_FF_B(x==y); break; + case i_neFloat: OP_FF_B(x!=y); break; + case i_ltFloat: OP_FF_B(x_mp_size, - stgCast(StgByteArray,x->_mp_d), - y)); break; - case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break; + if (y == 0) { + return (raiseDiv0("divideFloat")); + } #endif - case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break; - case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break; - case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break; - case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break; - case i_gtDouble: OP_DD_B(x>y); break; - case i_geDouble: OP_DD_B(x>=y); break; - case i_eqDouble: OP_DD_B(x==y); break; - case i_neDouble: OP_DD_B(x!=y); break; - case i_ltDouble: OP_DD_B(xy); break; + case i_geDouble: OP_DD_B(x>=y); break; + case i_eqDouble: OP_DD_B(x==y); break; + case i_neDouble: OP_DD_B(x!=y); break; + case i_ltDouble: OP_DD_B(x_mp_size, - stgCast(StgByteArray,x->_mp_d), - y)); break; - case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break; -#endif /* PROVIDE_INTEGER */ - case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break; - case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break; - case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break; - case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break; - case i_isIEEEDouble: - { - PushTaggedBool(rtsTrue); - } - break; - default: - barf("Unrecognised primop1"); - } - break; - } - case i_PRIMOP2: - { - switch (bcoInstr(bco,pc++)) { - case i_INTERNAL_ERROR2: - barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1); - - case i_raise: /* raise#{err} */ - { - StgClosure* err = PopCPtr(); - obj = raiseAnError(err); - goto enterLoop; - } -#ifdef PROVIDE_ARRAY - case i_newRef: - { - StgClosure* init = PopCPtr(); - StgMutVar* mv - = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar))); - SET_HDR(mv,&MUT_VAR_info,CCCS); - mv->var = init; - PushPtr(stgCast(StgPtr,mv)); - break; - } - case i_readRef: - { - StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); - PushCPtr(mv->var); - break; - } - case i_writeRef: - { - StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); - StgClosure* value = PopCPtr(); - mv->var = value; - break; - } - case i_newArray: - { - nat n = PopTaggedInt(); /* or Word?? */ - StgClosure* init = PopCPtr(); - StgWord size = sizeofW(StgMutArrPtrs) + n; - nat i; - StgMutArrPtrs* arr - = stgCast(StgMutArrPtrs*,allocate(size)); - SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS); - arr->ptrs = n; - for (i = 0; i < n; ++i) { - arr->payload[i] = init; - } - PushPtr(stgCast(StgPtr,arr)); - break; - } - case i_readArray: - case i_indexArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - nat i = PopTaggedInt(); /* or Word?? */ - StgWord n = arr->ptrs; - if (i >= n) { - obj = raiseIndex("{index,read}Array"); - goto enterLoop; - } - PushCPtr(arr->payload[i]); - break; - } - case i_writeArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - nat i = PopTaggedInt(); /* or Word? */ - StgClosure* v = PopCPtr(); - StgWord n = arr->ptrs; - if (i >= n) { - obj = raiseIndex("{index,read}Array"); - goto enterLoop; - } - arr->payload[i] = v; - break; - } - case i_sizeArray: - case i_sizeMutableArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - PushTaggedInt(arr->ptrs); - break; - } - case i_unsafeFreezeArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info); - PushPtr(stgCast(StgPtr,arr)); - break; - } - case i_unsafeFreezeByteArray: - { - /* Delightfully simple :-) */ - break; - } - case i_sameRef: - case i_sameMutableArray: - case i_sameMutableByteArray: - { - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } + case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break; + case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break; + case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break; + case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break; + case i_isIEEEDouble: + { + PushTaggedBool(rtsTrue); + } + break; + default: + barf("Unrecognised primop1"); + } + return NULL; +} + + - case i_newByteArray: - { - nat n = PopTaggedInt(); /* or Word?? */ - StgInt words = (n+sizeof(W_)-1)/sizeof(W_); - StgWord size = sizeofW(StgArrWords) + words; - nat i; - StgArrWords* arr = stgCast(StgArrWords*,allocate(size)); - SET_HDR(arr,&ARR_WORDS_info,CCCS); - arr->words = words; +/* For normal cases, return NULL and leave *return2 unchanged. + To return the address of the next thing to enter, + return the address of it and leave *return2 unchanged. + To return a StgThreadReturnCode to the scheduler, + set *return2 to it and return a non-NULL value. +*/ +static void* enterBCO_primop2 ( int primop2code, + int* /*StgThreadReturnCode* */ return2 ) +{ + switch (primop2code) { + case i_raise: /* raise#{err} */ + { + StgClosure* err = PopCPtr(); + return (raiseAnError(err)); + } + + case i_newRef: + { + StgClosure* init = PopCPtr(); + StgMutVar* mv + = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar))); + SET_HDR(mv,&MUT_VAR_info,CCCS); + mv->var = init; + PushPtr(stgCast(StgPtr,mv)); + break; + } + case i_readRef: + { + StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); + PushCPtr(mv->var); + break; + } + case i_writeRef: + { + StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); + StgClosure* value = PopCPtr(); + mv->var = value; + break; + } + case i_newArray: + { + nat n = PopTaggedInt(); /* or Word?? */ + StgClosure* init = PopCPtr(); + StgWord size = sizeofW(StgMutArrPtrs) + n; + nat i; + StgMutArrPtrs* arr + = stgCast(StgMutArrPtrs*,allocate(size)); + SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS); + arr->ptrs = n; + for (i = 0; i < n; ++i) { + arr->payload[i] = init; + } + PushPtr(stgCast(StgPtr,arr)); + break; + } + case i_readArray: + case i_indexArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + nat i = PopTaggedInt(); /* or Word?? */ + StgWord n = arr->ptrs; + if (i >= n) { + return (raiseIndex("{index,read}Array")); + } + PushCPtr(arr->payload[i]); + break; + } + case i_writeArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + nat i = PopTaggedInt(); /* or Word? */ + StgClosure* v = PopCPtr(); + StgWord n = arr->ptrs; + if (i >= n) { + return (raiseIndex("{index,read}Array")); + } + arr->payload[i] = v; + break; + } + case i_sizeArray: + case i_sizeMutableArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + PushTaggedInt(arr->ptrs); + break; + } + case i_unsafeFreezeArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info); + PushPtr(stgCast(StgPtr,arr)); + break; + } + case i_unsafeFreezeByteArray: + { + /* Delightfully simple :-) */ + break; + } + case i_sameRef: + case i_sameMutableArray: + case i_sameMutableByteArray: + { + StgPtr x = PopPtr(); + StgPtr y = PopPtr(); + PushTaggedBool(x==y); + break; + } + + case i_newByteArray: + { + nat n = PopTaggedInt(); /* or Word?? */ + StgInt words = (n+sizeof(W_)-1)/sizeof(W_); + StgWord size = sizeofW(StgArrWords) + words; + StgArrWords* arr = stgCast(StgArrWords*,allocate(size)); + SET_HDR(arr,&ARR_WORDS_info,CCCS); + arr->words = words; #ifdef DEBUG - for (i = 0; i < n; ++i) { - arr->payload[i] = 0xdeadbeef; - } + {nat i; + for (i = 0; i < n; ++i) { + arr->payload[i] = 0xdeadbeef; + }} #endif - PushPtr(stgCast(StgPtr,arr)); - break; - } + PushPtr(stgCast(StgPtr,arr)); + break; + } - /* Most of these generate alignment warnings on Sparcs and similar architectures. + /* Most of these generate alignment warnings on Sparcs and similar architectures. * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. */ - case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; - case i_readCharArray: OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break; - case i_writeCharArray: OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break; - - case i_indexIntArray: OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break; - case i_readIntArray: OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break; - case i_writeIntArray: OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break; -#ifdef PROVIDE_INT64 - case i_indexInt64Array: OP_mI_ty(Int64,"indexInt64Array", indexInt64Arrayzh(r,x,i)); break; - case i_readInt64Array: OP_mI_ty(Int64,"readInt64Array", readInt64Arrayzh(r,x,i)); break; - case i_writeInt64Array: OP_mIty_(Int64,"writeInt64Array", writeInt64Arrayzh(x,i,z)); break; -#endif -#ifdef PROVIDE_ADDR - case i_indexAddrArray: OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break; - case i_readAddrArray: OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break; - case i_writeAddrArray: OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break; -#endif - case i_indexFloatArray: OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break; - case i_readFloatArray: OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break; - case i_writeFloatArray: OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break; - - case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break; - case i_readDoubleArray: OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break; - case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; + case i_indexCharArray: + OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; + case i_readCharArray: + OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break; + case i_writeCharArray: + OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break; + + case i_indexIntArray: + OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break; + case i_readIntArray: + OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break; + case i_writeIntArray: + OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break; + + case i_indexAddrArray: + OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break; + case i_readAddrArray: + OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break; + case i_writeAddrArray: + OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break; + + case i_indexFloatArray: + OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break; + case i_readFloatArray: + OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break; + case i_writeFloatArray: + OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break; + + case i_indexDoubleArray: + OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break; + case i_readDoubleArray: + OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break; + case i_writeDoubleArray: + OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; #ifdef PROVIDE_STABLE - case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; - case i_readStableArray: OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break; - case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; + case i_indexStableArray: + OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; + case i_readStableArray: + OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break; + case i_writeStableArray: + OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; #endif -#endif /* PROVIDE_ARRAY */ + + + #ifdef PROVIDE_COERCE - case i_unsafeCoerce: - { - /* Another nullop */ - break; - } + case i_unsafeCoerce: + { + /* Another nullop */ + break; + } #endif #ifdef PROVIDE_PTREQUALITY - case i_reallyUnsafePtrEquality: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } + case i_reallyUnsafePtrEquality: + { /* identical to i_sameRef */ + StgPtr x = PopPtr(); + StgPtr y = PopPtr(); + PushTaggedBool(x==y); + break; + } #endif #ifdef PROVIDE_FOREIGN - /* ForeignObj# operations */ - case i_makeForeignObj: - { - StgForeignObj *result - = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); - SET_HDR(result,&FOREIGN_info,CCCS); - result -> data = PopTaggedAddr(); - PushPtr(stgCast(StgPtr,result)); - break; - } + /* ForeignObj# operations */ + case i_makeForeignObj: + { + StgForeignObj *result + = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); + SET_HDR(result,&FOREIGN_info,CCCS); + result -> data = PopTaggedAddr(); + PushPtr(stgCast(StgPtr,result)); + break; + } #endif /* PROVIDE_FOREIGN */ #ifdef PROVIDE_WEAK - case i_makeWeak: - { - StgWeak *w - = stgCast(StgWeak*,allocate(sizeofW(StgWeak))); - SET_HDR(w, &WEAK_info, CCCS); - w->key = PopCPtr(); - w->value = PopCPtr(); - w->finaliser = PopCPtr(); - w->link = weak_ptr_list; - weak_ptr_list = w; - IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w)); - PushPtr(stgCast(StgPtr,w)); - break; - } - case i_deRefWeak: - { - StgWeak *w = stgCast(StgWeak*,PopPtr()); - if (w->header.info == &WEAK_info) { - PushCPtr(w->value); /* last result */ - PushTaggedInt(1); /* first result */ - } else { - PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */ - PushTaggedInt(0); - } - break; - } + case i_makeWeak: + { + StgWeak *w + = stgCast(StgWeak*,allocate(sizeofW(StgWeak))); + SET_HDR(w, &WEAK_info, CCCS); + w->key = PopCPtr(); + w->value = PopCPtr(); + w->finaliser = PopCPtr(); + w->link = weak_ptr_list; + weak_ptr_list = w; + IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w)); + PushPtr(stgCast(StgPtr,w)); + break; + } + case i_deRefWeak: + { + StgWeak *w = stgCast(StgWeak*,PopPtr()); + if (w->header.info == &WEAK_info) { + PushCPtr(w->value); /* last result */ + PushTaggedInt(1); /* first result */ + } else { + PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */ + PushTaggedInt(0); + } + break; + } #endif /* PROVIDE_WEAK */ #ifdef PROVIDE_STABLE - /* StablePtr# operations */ - case i_makeStablePtr: - case i_deRefStablePtr: - case i_freeStablePtr: - { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" ); + /* StablePtr# operations */ + case i_makeStablePtr: + case i_deRefStablePtr: + case i_freeStablePtr: + { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" ); exit(1); }; #if 0 ToDo: reinstate - case i_makeStablePtr: - { - StgStablePtr stable_ptr; - if (stable_ptr_free == NULL) { - enlargeStablePtrTable(); - } - - stable_ptr = stable_ptr_free - stable_ptr_table; - stable_ptr_free = (P_*)*stable_ptr_free; - stable_ptr_table[stable_ptr] = PopPtr(); - - PushTaggedStablePtr(stable_ptr); - break; - } - case i_deRefStablePtr: - { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - PushPtr(stable_ptr_table[stable_ptr]); - break; - } - - case i_freeStablePtr: - { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; - stable_ptr_free = stable_ptr_table + stable_ptr; - break; - } + case i_makeStablePtr: + { + StgStablePtr stable_ptr; + if (stable_ptr_free == NULL) { + enlargeStablePtrTable(); + } + + stable_ptr = stable_ptr_free - stable_ptr_table; + stable_ptr_free = (P_*)*stable_ptr_free; + stable_ptr_table[stable_ptr] = PopPtr(); + + PushTaggedStablePtr(stable_ptr); + break; + } + case i_deRefStablePtr: + { + StgStablePtr stable_ptr = PopTaggedStablePtr(); + PushPtr(stable_ptr_table[stable_ptr]); + break; + } + + case i_freeStablePtr: + { + StgStablePtr stable_ptr = PopTaggedStablePtr(); + stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; + stable_ptr_free = stable_ptr_table + stable_ptr; + break; + } #endif /* 0 */ #endif /* PROVIDE_STABLE */ #ifdef PROVIDE_CONCURRENT - case i_fork: - { - StgClosure* c = PopCPtr(); - StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c); - PushPtr(stgCast(StgPtr,t)); - - /* switch at the earliest opportunity */ - context_switch = 1; - /* but don't automatically switch to GHC - or you'll waste your - * time slice switching back. - * - * Actually, there's more to it than that: the default - * (ThreadEnterGHC) causes the thread to crash - don't - * understand why. - ADR - */ - t->whatNext = ThreadEnterHugs; - break; - } - case i_killThread: - { - StgTSO* tso = stgCast(StgTSO*,PopPtr()); - deleteThread(tso); - if (tso == CurrentTSO) { /* suicide */ - return ThreadFinished; - } - break; - } - case i_sameMVar: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } - case i_newMVar: - { - StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar))); - SET_INFO(mvar,&EMPTY_MVAR_info); - mvar->head = mvar->tail = EndTSOQueue; - /* ToDo: this is a little strange */ - mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure); - PushPtr(stgCast(StgPtr,mvar)); - break; - } + case i_fork: + { + StgClosure* c = PopCPtr(); + StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c); + PushPtr(stgCast(StgPtr,t)); + + /* switch at the earliest opportunity */ + context_switch = 1; + /* but don't automatically switch to GHC - or you'll waste your + * time slice switching back. + * + * Actually, there's more to it than that: the default + * (ThreadEnterGHC) causes the thread to crash - don't + * understand why. - ADR + */ + t->whatNext = ThreadEnterHugs; + break; + } + case i_killThread: + { + StgTSO* tso = stgCast(StgTSO*,PopPtr()); + deleteThread(tso); + if (tso == CurrentTSO) { /* suicide */ + *return2 = ThreadFinished; + return (void*)(1+(NULL)); + } + break; + } + case i_sameMVar: + { /* identical to i_sameRef */ + StgPtr x = PopPtr(); + StgPtr y = PopPtr(); + PushTaggedBool(x==y); + break; + } + case i_newMVar: + { + StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar))); + SET_INFO(mvar,&EMPTY_MVAR_info); + mvar->head = mvar->tail = EndTSOQueue; + /* ToDo: this is a little strange */ + mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure); + PushPtr(stgCast(StgPtr,mvar)); + break; + } #if 1 #if 0 ToDo: another way out of the problem might be to add an explicit @@ -2514,286 +2900,116 @@ continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar. The problem with this plan is that now I dont know how much to chop off the stack. #endif - case i_takeMVar: - { - StgMVar *mvar = stgCast(StgMVar*,PopPtr()); - /* If the MVar is empty, put ourselves - * on its blocking queue, and wait - * until we're woken up. - */ - if (GET_INFO(mvar) != &FULL_MVAR_info) { - if (mvar->head == EndTSOQueue) { - mvar->head = CurrentTSO; - } else { - mvar->tail->link = CurrentTSO; - } - CurrentTSO->link = EndTSOQueue; - mvar->tail = CurrentTSO; - - /* Hack, hack, hack. - * When we block, we push a restart closure - * on the stack - but which closure? - * We happen to know that the BCO we're - * executing looks like this: - * - * 0: STK_CHECK 4 - * 2: HP_CHECK 3 - * 4: TEST 0 29 - * 7: UNPACK - * 8: VAR 3 - * 10: VAR 1 - * 12: primTakeMVar - * 14: ALLOC_CONSTR 0x8213a80 - * 16: VAR 2 - * 18: VAR 2 - * 20: PACK 2 - * 22: VAR 0 - * 24: SLIDE 1 7 - * 27: ENTER - * 28: PANIC - * 29: PANIC - * - * so we rearrange the stack to look the - * way it did when we entered this BCO + case i_takeMVar: + { + StgMVar *mvar = stgCast(StgMVar*,PopPtr()); + /* If the MVar is empty, put ourselves + * on its blocking queue, and wait + * until we're woken up. + */ + if (GET_INFO(mvar) != &FULL_MVAR_info) { + if (mvar->head == EndTSOQueue) { + mvar->head = CurrentTSO; + } else { + mvar->tail->link = CurrentTSO; + } + CurrentTSO->link = EndTSOQueue; + mvar->tail = CurrentTSO; + + /* Hack, hack, hack. + * When we block, we push a restart closure + * on the stack - but which closure? + * We happen to know that the BCO we're + * executing looks like this: + * + * 0: STK_CHECK 4 + * 2: HP_CHECK 3 + * 4: TEST 0 29 + * 7: UNPACK + * 8: VAR 3 + * 10: VAR 1 + * 12: primTakeMVar + * 14: ALLOC_CONSTR 0x8213a80 + * 16: VAR 2 + * 18: VAR 2 + * 20: PACK 2 + * 22: VAR 0 + * 24: SLIDE 1 7 + * 27: ENTER + * 28: PANIC + * 29: PANIC + * + * so we rearrange the stack to look the + * way it did when we entered this BCO * and push ths BCO. - * What a disgusting hack! - */ - - PopPtr(); - PopPtr(); - PushCPtr(obj); - return ThreadBlocked; - - } else { - PushCPtr(mvar->value); - SET_INFO(mvar,&EMPTY_MVAR_info); - /* ToDo: this is a little strange */ - mvar->value = (StgClosure*)&END_TSO_QUEUE_closure; - } - break; - } + * What a disgusting hack! + */ + + PopPtr(); + PopPtr(); + PushCPtr(obj); + *return2 = ThreadBlocked; + return (void*)(1+(NULL)); + + } else { + PushCPtr(mvar->value); + SET_INFO(mvar,&EMPTY_MVAR_info); + /* ToDo: this is a little strange */ + mvar->value = (StgClosure*)&END_TSO_QUEUE_closure; + } + break; + } #endif - case i_putMVar: - { - StgMVar* mvar = stgCast(StgMVar*,PopPtr()); - StgClosure* value = PopCPtr(); - if (GET_INFO(mvar) == &FULL_MVAR_info) { - obj = raisePrim("putMVar {full MVar}"); - goto enterLoop; - } else { - /* wake up the first thread on the - * queue, it will continue with the - * takeMVar operation and mark the - * MVar empty again. - */ - StgTSO* tso = mvar->head; - SET_INFO(mvar,&FULL_MVAR_info); - mvar->value = value; - if (tso != EndTSOQueue) { - PUSH_ON_RUN_QUEUE(tso); - mvar->head = tso->link; - tso->link = EndTSOQueue; - if (mvar->head == EndTSOQueue) { - mvar->tail = EndTSOQueue; - } - } - } - /* yield for better communication performance */ - context_switch = 1; - break; - } - case i_delay: - case i_waitRead: - case i_waitWrite: - /* As PrimOps.h says: Hmm, I'll think about these later. */ - ASSERT(0); - break; -#endif /* PROVIDE_CONCURRENT */ - case i_ccall_Id: - case i_ccall_IO: - { - CFunDescriptor* descriptor = PopTaggedAddr(); - StgAddr funPtr = PopTaggedAddr(); - ccall(descriptor,funPtr); - break; - } - default: - barf("Unrecognised primop2"); + case i_putMVar: + { + StgMVar* mvar = stgCast(StgMVar*,PopPtr()); + StgClosure* value = PopCPtr(); + if (GET_INFO(mvar) == &FULL_MVAR_info) { + return (raisePrim("putMVar {full MVar}")); + } else { + /* wake up the first thread on the + * queue, it will continue with the + * takeMVar operation and mark the + * MVar empty again. + */ + StgTSO* tso = mvar->head; + SET_INFO(mvar,&FULL_MVAR_info); + mvar->value = value; + if (tso != EndTSOQueue) { + PUSH_ON_RUN_QUEUE(tso); + mvar->head = tso->link; + tso->link = EndTSOQueue; + if (mvar->head == EndTSOQueue) { + mvar->tail = EndTSOQueue; } - break; } - default: - pc--; - printf ( "\n\n" ); - disInstr ( bco, pc ); - barf("\nUnrecognised instruction"); } + /* yield for better communication performance */ + context_switch = 1; + break; } - barf("Ran off the end of bco - yoiks"); - break; - } - case CAF_UNENTERED: - { - StgBlockingQueue* bh; - StgCAF* caf = (StgCAF*)obj; - if (Sp - sizeofW(StgUpdateFrame) < SpLim) { - PushCPtr(obj); /* code to restart with */ - return StackOverflow; - } - /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME - and insert an indirection immediately */ - bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); - SET_INFO(bh,&CAF_BLACKHOLE_info); - bh->blocking_queue = EndTSOQueue; - IF_DEBUG(gccafs, - fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf)); - SET_INFO(caf,&CAF_ENTERED_info); - caf->value = (StgClosure*)bh; - recordOldToNewPtrs(caf); - PUSH_UPD_FRAME(bh,0); - Sp -= sizeofW(StgUpdateFrame); - caf->link = enteredCAFs; - enteredCAFs = caf; - obj = caf->body; - goto enterLoop; - } - case CAF_ENTERED: - { - StgCAF* caf = (StgCAF*)obj; - obj = caf->value; /* it's just a fancy indirection */ - goto enterLoop; - } - case BLACKHOLE: - case CAF_BLACKHOLE: - { - /*was StgBlackHole* */ - StgBlockingQueue* bh = (StgBlockingQueue*)obj; - /* Put ourselves on the blocking queue for this black hole and block */ - CurrentTSO->link = bh->blocking_queue; - bh->blocking_queue = CurrentTSO; - PushCPtr(obj); /* code to restart with */ - assert(0); - return ThreadBlocked; - } - case AP_UPD: - { - StgAP_UPD* ap = stgCast(StgAP_UPD*,obj); - int i = ap->n_args; - if (Sp - (i + sizeofW(StgUpdateFrame)) < SpLim) { - PushCPtr(obj); /* code to restart with */ - return StackOverflow; - } - /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME - and insert an indirection immediately */ - PUSH_UPD_FRAME(ap,0); - Sp -= sizeofW(StgUpdateFrame); - while (--i >= 0) { - PushWord(payloadWord(ap,i)); - } - obj = ap->fun; -#ifndef LAZY_BLACKHOLING + case i_delay: + case i_waitRead: + case i_waitWrite: + /* As PrimOps.h says: Hmm, I'll think about these later. */ + ASSERT(0); + break; +#endif /* PROVIDE_CONCURRENT */ + case i_ccall_Id: + case i_ccall_IO: { - /* superfluous - but makes debugging easier */ - StgBlackHole* bh = stgCast(StgBlackHole*,ap); - SET_INFO(bh,&BLACKHOLE_info); - bh->blocking_queue = EndTSOQueue; - IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); - /*printObj(bh); */ - } -#endif /* LAZY_BLACKHOLING */ - goto enterLoop; - } - case PAP: - { - StgPAP* pap = stgCast(StgPAP*,obj); - int i = pap->n_args; /* ToDo: stack check */ - /* ToDo: if PAP is in whnf, we can update any update frames - * on top of stack. - */ - while (--i >= 0) { - PushWord(payloadWord(pap,i)); - } - obj = pap->fun; - goto enterLoop; - } - case IND: - { - obj = stgCast(StgInd*,obj)->indirectee; - goto enterLoop; - } - case IND_OLDGEN: - { - obj = stgCast(StgIndOldGen*,obj)->indirectee; - goto enterLoop; - } - case CONSTR: - case CONSTR_INTLIKE: - case CONSTR_CHARLIKE: - case CONSTR_STATIC: - case CONSTR_NOCAF_STATIC: - { - while (1) { - switch (get_itbl(stgCast(StgClosure*,Sp))->type) { - case CATCH_FRAME: - PopCatchFrame(); - break; - case UPDATE_FRAME: - PopUpdateFrame(obj); - break; - case SEQ_FRAME: - PopSeqFrame(); - break; - case STOP_FRAME: - { - ASSERT(Sp==(P_)Su); - IF_DEBUG(evaluator, - printObj(obj); - /*fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);*/ - /*printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);*/ - ); - PopStopFrame(obj); - return ThreadFinished; - } - case RET_BCO: - { - StgClosure* ret; - PopPtr(); - ret = PopCPtr(); - PushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - case RET_SMALL: /* return to GHC */ - case RET_VEC_SMALL: - case RET_BIG: - case RET_VEC_BIG: - barf("todo: RET_[VEC_]{BIG,SMALL}"); - default: - belch("entered CONSTR with invalid continuation on stack"); - IF_DEBUG(evaluator, - printObj(stgCast(StgClosure*,Sp)) - ); - barf("bailing out"); - } + CFunDescriptor* descriptor = PopTaggedAddr(); + StgAddr funPtr = PopTaggedAddr(); + ccall(descriptor,funPtr); + break; } - } - default: - { -fprintf(stderr, "enterCountI = %d\n", enterCountI); -fprintf(stderr, "panic: enter: entered unknown closure\n"); -printObj(obj); -fprintf(stderr, "what it points at is\n"); -printObj( ((StgEvacuated*)obj) ->evacuee); -exit(1); - CurrentTSO->whatNext = ThreadEnterGHC; - PushCPtr(obj); /* code to restart with */ - return ThreadYielding; - } - } - barf("Ran off the end of enter - yoiks"); - assert(0); + default: + barf("Unrecognised primop2"); + } + return NULL; } + /* ----------------------------------------------------------------------------- * ccall support code: * marshall moves args from C stack to Haskell stack @@ -2811,21 +3027,14 @@ nat marshall(char arg_ty, void* arg) case INT_REP: PushTaggedInt(*((int*)arg)); return ARG_SIZE(INT_TAG); -#ifdef PROVIDE_INT64 - case INT64_REP: - PushTaggedInt64(*((StgInt64*)arg)); - return ARG_SIZE(INT64_TAG); -#endif -#ifdef TODO_PROVIDE_INTEGER +#ifdef TODO_STANDALONE_INTEGER case INTEGER_REP: PushTaggedInteger(*((mpz_ptr*)arg)); return ARG_SIZE(INTEGER_TAG); #endif -#ifdef PROVIDE_WORD case WORD_REP: PushTaggedWord(*((unsigned int*)arg)); return ARG_SIZE(WORD_TAG); -#endif case CHAR_REP: PushTaggedChar(*((char*)arg)); return ARG_SIZE(CHAR_TAG); @@ -2835,26 +3044,24 @@ nat marshall(char arg_ty, void* arg) case DOUBLE_REP: PushTaggedDouble(*((double*)arg)); return ARG_SIZE(DOUBLE_TAG); -#ifdef PROVIDE_ADDR case ADDR_REP: PushTaggedAddr(*((void**)arg)); return ARG_SIZE(ADDR_TAG); -#endif #ifdef PROVIDE_STABLE case STABLE_REP: PushTaggedStablePtr(*((StgStablePtr*)arg)); return ARG_SIZE(STABLE_TAG); #endif +#ifdef PROVIDE_FOREIGN case FOREIGN_REP: /* Not allowed in this direction - you have to * call makeForeignPtr explicitly */ barf("marshall: ForeignPtr#\n"); break; -#ifdef PROVIDE_ARRAY +#endif case BARR_REP: case MUTBARR_REP: -#endif /* Not allowed in this direction */ barf("marshall: [Mutable]ByteArray#\n"); break; @@ -2874,21 +3081,14 @@ nat unmarshall(char res_ty, void* res) case INT_REP: *((int*)res) = PopTaggedInt(); return ARG_SIZE(INT_TAG); -#ifdef PROVIDE_INT64 - case INT64_REP: - *((StgInt64*)res) = PopTaggedInt64(); - return ARG_SIZE(INT64_TAG); -#endif -#ifdef TODO_PROVIDE_INTEGER +#ifdef TODO_STANDALONE_INTEGER case INTEGER_REP: *((mpz_ptr*)res) = PopTaggedInteger(); return ARG_SIZE(INTEGER_TAG); #endif -#ifdef PROVIDE_WORD case WORD_REP: *((unsigned int*)res) = PopTaggedWord(); return ARG_SIZE(WORD_TAG); -#endif case CHAR_REP: *((int*)res) = PopTaggedChar(); return ARG_SIZE(CHAR_TAG); @@ -2898,26 +3098,24 @@ nat unmarshall(char res_ty, void* res) case DOUBLE_REP: *((double*)res) = PopTaggedDouble(); return ARG_SIZE(DOUBLE_TAG); -#ifdef PROVIDE_ADDR case ADDR_REP: *((void**)res) = PopTaggedAddr(); return ARG_SIZE(ADDR_TAG); -#endif #ifdef PROVIDE_STABLE case STABLE_REP: *((StgStablePtr*)res) = PopTaggedStablePtr(); return ARG_SIZE(STABLE_TAG); #endif +#ifdef PROVIDE_FOREIGN case FOREIGN_REP: { StgForeignObj *result = stgCast(StgForeignObj*,PopPtr()); *((void**)res) = result->data; return sizeofW(StgPtr); } -#ifdef PROVIDE_ARRAY +#endif case BARR_REP: case MUTBARR_REP: -#endif { StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); *((void**)res) = stgCast(void*,&(arr->payload)); @@ -2936,21 +3134,14 @@ nat argSize( const char* ks ) case INT_REP: sz += sizeof(StgWord) * ARG_SIZE(INT_TAG); break; -#ifdef PROVIDE_INT64 - case INT64_REP: - sz += sizeof(StgWord) * ARG_SIZE(INT64_TAG); - break; -#endif -#ifdef TODO_PROVIDE_INTEGER +#ifdef TODO_STANDALONE_INTEGER case INTEGER_REP: sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG); break; #endif -#ifdef PROVIDE_WORD case WORD_REP: sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG); break; -#endif case CHAR_REP: sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG); break; @@ -2960,11 +3151,9 @@ nat argSize( const char* ks ) case DOUBLE_REP: sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG); break; -#ifdef PROVIDE_ADDR case ADDR_REP: sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG); break; -#endif #ifdef PROVIDE_STABLE case STABLE_REP: sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG); @@ -2973,10 +3162,8 @@ nat argSize( const char* ks ) #ifdef PROVIDE_FOREIGN case FOREIGN_REP: #endif -#ifdef PROVIDE_ARRAY case BARR_REP: case MUTBARR_REP: -#endif sz += sizeof(StgPtr); break; default: @@ -2987,4 +3174,188 @@ nat argSize( const char* ks ) return sz; } + +/* ----------------------------------------------------------------------------- + * encode/decode Float/Double code for standalone Hugs + * Code based on the HBC code (lib/fltcode.c) and more recently GHC + * (ghc/rts/StgPrimFloat.c) + * ---------------------------------------------------------------------------*/ + +#ifdef STANDALONE_INTEGER + +#if IEEE_FLOATING_POINT +#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1) +/* DMINEXP is defined in values.h on Linux (for example) */ +#define DHIGHBIT 0x00100000 +#define DMSBIT 0x80000000 + +#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1) +#define FHIGHBIT 0x00800000 +#define FMSBIT 0x80000000 +#else +#error The following code doesnt work in a non-IEEE FP environment +#endif + +#ifdef WORDS_BIGENDIAN +#define L 1 +#define H 0 +#else +#define L 0 +#define H 1 +#endif + + +StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */ +{ + StgDouble r; + I_ i; + + /* Convert a B to a double; knows a lot about internal rep! */ + for(r = 0.0, i = s->used-1; i >= 0; i--) + r = (r * B_BASE_FLT) + s->stuff[i]; + + /* Now raise to the exponent */ + if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ + r = ldexp(r, e); + + /* handle the sign */ + if (s->sign < 0) r = -r; + + return r; +} + + + +#if ! FLOATS_AS_DOUBLES +StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */ +{ + StgFloat r; + I_ i; + + /* Convert a B to a float; knows a lot about internal rep! */ + for(r = 0.0, i = s->used-1; i >= 0; i--) + r = (r * B_BASE_FLT) + s->stuff[i]; + + /* Now raise to the exponent */ + if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ + r = ldexp(r, e); + + /* handle the sign */ + if (s->sign < 0) r = -r; + + return r; +} +#endif /* FLOATS_AS_DOUBLES */ + + + +/* This only supports IEEE floating point */ +void B__decodeDouble (B* man, I_* exp, StgDouble dbl) +{ + /* Do some bit fiddling on IEEE */ + nat low, high; /* assuming 32 bit ints */ + int sign, iexp; + union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ + + u.d = dbl; /* grab chunks of the double */ + low = u.i[L]; + high = u.i[H]; + + ASSERT(B_BASE == 256); + + /* Assume that the supplied B is the right size */ + man->size = 8; + + if (low == 0 && (high & ~DMSBIT) == 0) { + man->sign = man->used = 0; + *exp = 0L; + } else { + man->used = 8; + man->sign = 1; + iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; + sign = high; + + high &= DHIGHBIT-1; + if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */ + high |= DHIGHBIT; + else { + iexp++; + /* A denorm, normalize the mantissa */ + while (! (high & DHIGHBIT)) { + high <<= 1; + if (low & DMSBIT) + high++; + low <<= 1; + iexp--; + } + } + *exp = (I_) iexp; + + man->stuff[7] = (((W_)high) >> 24) & 0xff; + man->stuff[6] = (((W_)high) >> 16) & 0xff; + man->stuff[5] = (((W_)high) >> 8) & 0xff; + man->stuff[4] = (((W_)high) ) & 0xff; + + man->stuff[3] = (((W_)low) >> 24) & 0xff; + man->stuff[2] = (((W_)low) >> 16) & 0xff; + man->stuff[1] = (((W_)low) >> 8) & 0xff; + man->stuff[0] = (((W_)low) ) & 0xff; + + if (sign < 0) man->sign = -1; + } + do_renormalise(man); +} + + +#if ! FLOATS_AS_DOUBLES +void B__decodeFloat (B* man, I_* exp, StgFloat flt) +{ + /* Do some bit fiddling on IEEE */ + int high, sign; /* assuming 32 bit ints */ + union { float f; int i; } u; /* assuming 32 bit float and int */ + + u.f = flt; /* grab the float */ + high = u.i; + + ASSERT(B_BASE == 256); + + /* Assume that the supplied B is the right size */ + man->size = 4; + + if ((high & ~FMSBIT) == 0) { + man->sign = man->used = 0; + *exp = 0; + } else { + man->used = 4; + man->sign = 1; + *exp = ((high >> 23) & 0xff) + MY_FMINEXP; + sign = high; + + high &= FHIGHBIT-1; + if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */ + high |= FHIGHBIT; + else { + (*exp)++; + /* A denorm, normalize the mantissa */ + while (! (high & FHIGHBIT)) { + high <<= 1; + (*exp)--; + } + } + man->stuff[3] = (((W_)high) >> 24) & 0xff; + man->stuff[2] = (((W_)high) >> 16) & 0xff; + man->stuff[1] = (((W_)high) >> 8) & 0xff; + man->stuff[0] = (((W_)high) ) & 0xff; + + if (sign < 0) man->sign = -1; + } + do_renormalise(man); +} + +#endif /* FLOATS_AS_DOUBLES */ + +#endif /* STANDALONE_INTEGER */ + + + #endif /* INTERPRETER */ diff --git a/ghc/rts/QueueTemplate.h b/ghc/rts/QueueTemplate.h index a16d12b..2fb146e 100644 --- a/ghc/rts/QueueTemplate.h +++ b/ghc/rts/QueueTemplate.h @@ -1,24 +1,23 @@ -/* -*- mode: hugs-c; -*- */ + /* ----------------------------------------------------------------------------- - * $Id: QueueTemplate.h,v 1.3 1999/02/05 16:02:48 simonm Exp $ + * $Id: QueueTemplate.h,v 1.4 1999/04/27 10:07:19 sewardj Exp $ * * (c) The GHC Team, 1998 * * Template for generating queues of various types * - * #define Queue##ChunkSize, Queue and Type before #including this file + * #define Queue and Type before #including this file * to define the following: * - * typedef { ...; nat len } Queue; + * typedef { Type* elems; nat used; nat size } Queue; * static void insertQueue( Queue* q, Type i ); * static void initQueue ( Queue* q ); * static void setQueue ( Queue* q, nat i, Type x ); - * - * Copyright (c) 1994-1998. + * static void freeQueue ( Queue* q ); * * $RCSfile: QueueTemplate.h,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/05 16:02:48 $ + * $Revision: 1.4 $ + * $Date: 1999/04/27 10:07:19 $ * * ------------------------------------------------------------------------*/ @@ -30,81 +29,72 @@ #define mycat2(x,y) mycat(x,y) #define mycat3(x,y,z) mycat2(x,mycat2(y,z)) -typedef struct mycat3(_,Queue,Chunk) { - struct mycat3(_,Queue,Chunk)* next; - Type xs[mycat2(Queue,ChunkSize)]; -} mycat2(Queue,Chunk); - -static mycat2(Queue,Chunk)* mycat3(alloc,Queue,Chunk)( void ) -{ - mycat2(Queue,Chunk)* new = malloc(sizeof(mycat2(Queue,Chunk))); - if (new == NULL) { - barf("Can't allomycate " mystr(Queue) "Chunk"); - } - new->next = NULL; - return new; -} typedef struct { - mycat2(Queue,Chunk)* head; - mycat2(Queue,Chunk)* tail; - nat len; /* position of next free instruction */ + Type* elems; + nat len; /* always <= size */ + nat size; } Queue; -static void mycat2(insert,Queue)( Queue* q, Type i ) + +static void mycat2(init,Queue)( Queue* q ) { - if (q->len == 0) { - mycat2(Queue,Chunk)* new = mycat3(alloc,Queue,Chunk)(); - new->next = NULL; - q->head = new; - q->tail = new; - } else if (q->len % mycat2(Queue,ChunkSize) == 0) { - mycat2(Queue,Chunk)* new = mycat3(alloc,Queue,Chunk)(); - new->next = NULL; - q->tail->next = new; - q->tail = new; - } - q->tail->xs[q->len % mycat2(Queue,ChunkSize)] = i; - q->len++; + q->len = 0; + q->size = 8; + q->elems = malloc(q->size * sizeof(Type)); + if (q->elems == NULL) { + barf("Out of memory: can't allocate initial " mystr(Queue) " space"); + } } + -static inline void mycat2(init,Queue)( Queue* q ) +static void mycat2(free,Queue)( Queue* q ) { - q->head = q->tail = NULL; - q->len = 0; + free(q->elems); + q->elems = NULL; } - -static void mycat2(set,Queue)( Queue* q, nat i, Type x ) + + +static void mycat2(insert,Queue)( Queue* q, Type x ) +{ + nat i; + if (q->len == q->size) { + Type* elems2 = malloc(2 * q->size * sizeof(Type)); + if (elems2 == NULL) { + barf("Out of memory: can't resize " mystr(Queue) " space"); + } + for (i = 0; i < q->len; i++) + elems2[i] = q->elems[i]; + free(q->elems); + q->elems = elems2; + q->size *= 2; + } + q->elems[q->len] = x; + q->len++; +} + + +void mycat2(set,Queue)( Queue* q, nat i, Type x ) { - mycat2(Queue,Chunk)* chunk = q->head; - ASSERT(i <= q->len); - /* ToDo: optimise case where i is in the last chunk in the list */ - for(; i >= mycat2(Queue,ChunkSize); i -= mycat2(Queue,ChunkSize)) { - ASSERT(chunk); - chunk = chunk->next; - } - ASSERT(chunk); - chunk->xs[i] = x; + ASSERT(i < q->len); + q->elems[i] = x; } + + /* evaluate a statement s once for every element in a queue q. * i and x are usually free in s * queueTy and eltTy are the types of the container and element respectively */ -#define mapQueue(queueTy,eltTy,q,s) \ -do { \ - mycat2(queueTy,Chunk)* chunk = (q).head; \ - nat i = 0; \ - eltTy x; \ - while( i < (q).len ) { \ - ASSERT(chunk); \ - x = chunk->xs[i % mycat2(queueTy,ChunkSize)]; \ - s; \ - ++i; \ - if (i % mycat2(queueTy,ChunkSize) == 0) { \ - chunk = chunk->next; \ - } \ - } \ +#define mapQueue(queueTy,eltTy,q,s) \ +do { \ + nat i = 0; \ + eltTy x; \ + while( i < (q).len ) { \ + x = q.elems[i]; \ + s; \ + ++i; \ + } \ } while (0) /* -------------------------------------------------------------------------- -- 1.7.10.4