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).
/* -----------------------------------------------------------------------------
- * $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.
*
/* 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
#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',
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 */
extern AsmClosure asmClosureOfObject ( AsmObject obj );
extern void asmMarkObject ( AsmObject obj );
+extern int asmRepSizeW ( AsmRep rep );
+
/* --------------------------------------------------------------------------
* Generating instruction streams
* ------------------------------------------------------------------------*/
/* 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 {
* 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 $
* ------------------------------------------------------------------------*/
* 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
#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
#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
/* 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.
/* 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
* 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
* 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.
*/
# ----------------------------------------------------------------------------- #
-# $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 = ../..
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
/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
# --------------------------------------------------------------------- #
# 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
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* | 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:
* 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 );
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)
/*-------------------------------------------------------------------------*/
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
* 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"
static void beginTop ( StgVar v );
static void endTop ( StgVar v );
+static StgVar currentTop;
+
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
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)) {
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! */
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 {
map1Proc(cgBind,bco,reverse(vs));
asmEndUnpack(bco);
}
- cgExpr(bco,root,body);
+ cgExpr(bco,root,stgCaseAltBody(alt));
asmEndAlt(bco,begin);
asmFixBranch(bco,fix);
}
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)));
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));
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);
}
}
-void* itblNames[1000];
+#define M_ITBLNAMES 35000
+
+void* itblNames[M_ITBLNAMES];
int nItblNames = 0;
/* allocate space for top level variable
} 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);
}
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;
{
StgRhs rhs;
assert(isStgVar(v));
+ currentTop = v;
rhs = stgVarBody(v);
switch (whatIs(rhs)) {
case STGCON:
break;
}
case LAMBDA:
+#ifdef CRUDE_PROFILING
+ setObj(v,asmBeginBCO(currentTop));
+#else
setObj(v,asmBeginBCO(rhs));
+#endif
break;
default:
setObj(v,asmBeginCAF());
static void endTop( StgVar v )
{
StgRhs rhs = stgVarBody(v);
- //ppStgRhs(rhs);
+ currentTop = v;
switch (whatIs(rhs)) {
case STGCON:
{
}
#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);
* 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;
#define INFO 15
#define COLLECT 16
#define SETMODULE 17
-#define NOCMD 18
+#define DUMP 18
+#define STATS 19
+#define NOCMD 20
/*-------------------------------------------------------------------------*/
* 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"
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
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)
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)) {
case INTCELL :
case FLOATCELL :
case STRCELL :
+ case BIGCELL :
case CHARCELL : return e;
case FINLIST : mapOver(translate,snd(e));
case AP : return pmcPair(co,sc,e);
-#if BIGNUMS
- case POSNUM :
- case ZERONUM :
- case NEGNUM :
-#endif
#if NPLUSK
case ADDPAT :
#endif
case NAME :
case CHARCELL :
case INTCELL :
+ case BIGCELL :
case FLOATCELL:
case STRCELL : break;
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;
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*/
}
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))) {
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?)
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)));
/* 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 */
RevertCAFs();
break;
case Success:
+ RevertCAFs();
break;
default:
internal("evalExp: Unrecognised SchedulerStatus");
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*/
}
}
- 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));
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();
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)));
}
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);
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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
extern Class classRead;
extern Class classIx;
extern Class classEnum;
-#if EVAL_INSTANCES
-extern Class classEval;
-#endif
extern Class classBounded;
extern Class classReal; /* `numeric' classes */
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 */
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 */
#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));
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));
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));
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));
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
* 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"
#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]) */
/* --------------------------------------------------------------------------
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));
static List local mkBndBinds Args((Int,Cell,Int));
-
/* --------------------------------------------------------------------------
* Deriving Utilities
* ------------------------------------------------------------------------*/
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 */
}
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)) {
}
return FALSE;
}
-#endif
+
/* --------------------------------------------------------------------------
* Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
* constructors in the datatype definition.
* ------------------------------------------------------------------------*/
-#if DERIVE_EQ
-
static Pair local mkAltEq Args((Int,List));
List deriveEq(t) /* generate binding for derived == */
}
return pair(pats,pair(mkInt(line),e));
}
-#endif /* DERIVE_EQ */
-#if DERIVE_ORD
static Pair local mkAltOrd Args((Int,List));
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;
/* 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));
e = singleton(pair(pats,pair(mkInt(line),e)));
return mkBind("inRange",e);
}
-#endif /* DERIVE_IX */
/* --------------------------------------------------------------------------
* Deriving Bounded:
* ------------------------------------------------------------------------*/
-#if DERIVE_BOUNDED
-
List deriveBounded(t) /* construct definition of bounds */
Tycon t; {
if (isEnumType(t)) {
cons(mkBind("maxBound",mkVarAlts(line,maxB)),
NIL));
}
-#endif /* DERIVE_BOUNDED */
-
/* --------------------------------------------------------------------------
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);
Void implementTagToCon(t)
Tycon t; {
if (isNull(tycon(t).tagToCon)) {
- String etxt;
String tyconname;
List cs;
Name nm;
StgVar bind2;
StgVar bind3;
List alts;
+ char etxt[200];
assert(nameMkA);
assert(nameUnpackString);
|| 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'",
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);
}
}
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;
}
}
* 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"
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);
}
case NAME:
return acc; /* Names are never free vars */
default:
+printf("\n\n");
+ppStgExpr(e);
+printf("\n");
internal("freeVarsExpr");
}
}
* 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 <setjmp.h>
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));
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 */
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? */
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");
Int argc;
String argv[]; {
Script i;
- String proj = 0;
+ String proj = 0;
+ char argv_0_orig[1000];
setLastEdit((String)0,0);
lastEdit = 0;
#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<argc; ++i) { /* process command line arguments */
+ if (strcmp(argv[i], "--")==0) break;
if (strcmp(argv[i],"+")==0 && i+1<argc) {
if (proj) {
ERRMSG(0) "Multiple project filenames on command line"
}
#ifdef DEBUG
- DEBUG_LoadSymbols(argv[0]);
+ DEBUG_LoadSymbols(argv_0_orig);
#endif
scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE,hugsPath));
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
Printf(fmts,"Fstr","Set preprocessor filter to str");
#endif
-#if PROFILING
- Printf(fmts,"dnum","Gather profiling statistics every <num> reductions\n");
-#endif
Printf("\nCurrent settings: ");
togglesIn(TRUE);
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');
#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;
}
while (*++s)
switch (*s) {
+ case 'Q' : break; /* already handled */
+
case 'p' : if (s[1]) {
if (prompt) free(prompt);
prompt = strCopy(s+1);
{":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}
};
Printf(":project <filename> use project file\n");
Printf(":edit <filename> edit file\n");
Printf(":edit edit last module\n");
-#if !IGNORE_MODULES
Printf(":module <module> set module for evaluating expressions\n");
-#endif
Printf("<expr> evaluate expression\n");
Printf(":type <expr> print type of expression\n");
Printf(":? display this list of commands\n");
Printf(":!command shell escape\n");
Printf(":cd dir change directory\n");
Printf(":gc force garbage collection\n");
+ Printf(":dump <name> print STG code for named fn\n");
+#ifdef CRUDE_PROFILING
+ Printf(":ztats <name> print reduction stats\n");
+#endif
Printf(":quit exit Hugs interpreter\n");
}
{'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
* 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 */
m = lastModule();
return m;
}
-#endif
static Void local evaluator() { /* evaluate expr and print value */
Type type, bd;
EEND;
}
-#if PROFILING
- if (profiling)
- profilerLog("profile.hp");
- numReductions = 0;
- garbageCollect();
-#endif
-
#ifdef WANT_TIMER
updateTimers();
#endif
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);
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));
#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<nameHw; i++)
+ if (name(i).text == t) n = i;
+
+ /* perhaps it's an "idNNNNNN" thing? */
+ if (isNull(n) &&
+ strlen(s) >= 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;
internal("Combined prompt and evaluation module name too long");
}
#endif
- consoleInput(promptBuffer);
+ if (autoMain)
+ stringInput("main\0"); else
+ consoleInput(promptBuffer);
}
/* --------------------------------------------------------------------------
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 */
break;
case PROJECT: project();
break;
-#if !IGNORE_MODULES
case SETMODULE :
setModule();
break;
-#endif
case EVAL : evaluator();
break;
case TYPEOF : showtype();
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;
break;
case INFO : info();
break;
+ case DUMP : dumpStg();
+ break;
case QUIT : return;
case COLLECT: consGC = FALSE;
garbageCollect();
Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
millisecs(userElapsed), millisecs(systElapsed));
#endif
+ if (autoMain) break;
}
breakOn(FALSE);
}
typeChecker(what);
compiler(what);
codegen(what);
+ optimiser(what);
}
/* --------------------------------------------------------------------------
#if HUGS_FOR_WINDOWS
#include "winhugs.c"
#endif
-
-/*-------------------------------------------------------------------------*/
-
* 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"
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:
* ------------------------------------------------------------------------*/
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<r);
-#if BIGNUMS
- return nonNull(big) ? big : mkInt(n);
-#else
- return mkInt(n);
-#endif
+ }
+ endToken();
+
+ if (doesNotExceed(tokenStr,r,MAXPOSINT))
+ return mkInt(stringToInt(tokenStr,r));
+ else
+ if (r == 10)
+ return stringToBignum(tokenStr);
+ else {
+ ERRMSG(row) "Hexadecimal or octal constant exceeds `Int' range"
+ EEND;
}
}
static Cell local readNumber() { /* read numeric constant */
- Int n = 0;
- Bool intTooLarge = FALSE;
if (c0=='0') {
if (c1=='x' || c1=='X') /* Maybe a hexadecimal literal? */
startToken();
do {
- if (overflows(n,10,(c0-'0'),MAXPOSINT))
- intTooLarge = TRUE;
- n = 10*n + (c0-'0');
saveTokenChar(c0);
skip();
} while (isISO(c0) && isIn(c0,DIGIT));
if (c0!='.' || !isISO(c1) || !isIn(c1,DIGIT)) {
endToken();
- if (!intTooLarge)
- return mkInt(n);
-#if BIGNUMS
- return bigStr(tokenStr);
-#else
- ERRMSG(row) "Integer literal out of range"
- EEND;
-#endif
+ if (doesNotExceed(tokenStr,10,MAXPOSINT))
+ return mkInt(stringToInt(tokenStr,10)); else
+ return stringToBignum(tokenStr);
}
saveTokenChar(c0); /* save decimal point */
return mkFloat(stringToFloat(tokenStr));
}
+
+
+
+
+
+
static Cell local readChar() { /* read character constant */
Cell charRead;
data Array ix elt = Array (ix,ix) (PrimArray elt)
array :: Ix a => (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
--- /dev/null
+
+-----------------------------------------------------------------------------
+-- 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 ("<<handle " ++ name h ++ "=" ++ show (file h) ++ ">>")
+
+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
+
+-----------------------------------------------------------------------------
+
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} ----------------------------------------
instance Integral Integer where
quotRem = primQuotRemInteger
- divMod = primDivModInteger
+ --divMod = primDivModInteger
toInteger = id
toInt = primIntegerToInt
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
instance Show Integer where
showsPrec = showSigned showInt
+
-- Standard Floating types --------------------------------------------------
data Float -- builtin datatype of single precision floating point numbers
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 --------------------------------------------------
-- 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'
-- 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
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)
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 ->
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 ->
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 ->
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
= 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 --------------------------------------------------------------------
------------------------------------------------------------------------------
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
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))
------------------------------------------------------------------------------
--- Addr, ForeignObj, Prim*Array ----------------------------------------------
+-- Word, Addr, ForeignObj, Prim*Array ----------------------------------------
------------------------------------------------------------------------------
data Addr
(>) = 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
data PrimMutableByteArray s
+
------------------------------------------------------------------------------
-- hooks to call libHS_cbits -------------------------------------------------
------------------------------------------------------------------------------
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 ->
(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)
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]]
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- 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
+
+-----------------------------------------------------------------------------
* 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"
* 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 );
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);
}
}
}
-static List liftLetBinds( List binds )
+static List liftLetBinds( List binds, Bool topLevel )
{
List bs = NIL;
for(; nonNull(binds); binds=tl(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:
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;
}
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
static void liftAlt( StgCaseAlt alt )
{
- liftExpr(stgCaseAltBody(alt));
+ if (isDefaultAlt(alt))
+ liftExpr(stgDefaultBody(alt)); else
+ liftExpr(stgCaseAltBody(alt));
}
static void liftPrimAlt( StgPrimAlt alt )
{
switch (whatIs(e)) {
case LETREC:
- stgLetBinds(e) = liftLetBinds(stgLetBinds(e));
+ stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
liftExpr(stgLetBody(e));
break;
case LAMBDA:
}
}
+/* 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;
}
* 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"
#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)) */
/* --------------------------------------------------------------------------
*
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
= 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 */
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<NUM_TUPLES; ++i) {
implementTuple(i);
setCurrModule(modulePrelude);
/* primops */
- QQ(nameMkIO) = linkName("primMkIO");
+ nameMkIO = linkName("primMkIO");
for (i=0; asmPrimOps[i].name; ++i) {
Text t = findText(asmPrimOps[i].name);
Name n = findName(t);
}
/* static(tidyInfix) */
- QQ(nameNegate ) = linkName("negate");
+ nameNegate = linkName("negate");
/* user interface */
- QQ(nameRunIO ) = linkName("primRunIO");
- QQ(namePrint ) = linkName("print");
- /* typechecker (undefined member functions) */
- //qqfail QQ(nameError ) = linkName("error");
+ nameRunIO = linkName("primRunIO");
+ namePrint = linkName("print");
/* desugar */
- //qqfail QQ(nameId ) = linkName("id");
- QQ(nameOtherwise ) = linkName("otherwise");
- QQ(nameUndefined ) = linkName("undefined");
+ nameOtherwise = linkName("otherwise");
+ nameUndefined = linkName("undefined");
/* pmc */
#if NPLUSK
namePmSub = linkName("primPmSub");
#endif
/* translator */
- ////nameUnpackString = linkName("primUnpackString");
- ////namePMFail = linkName("primPmFail");
- QQ(nameEqChar ) = linkName("primEqChar");
- QQ(nameEqInt ) = linkName("primEqInt");
+ nameEqChar = linkName("primEqChar");
+ nameEqInt = linkName("primEqInt");
#if !OVERLOADED_CONSTANTS
- QQ(nameEqInteger ) = linkName("primEqInteger");
+ nameEqInteger = linkName("primEqInteger");
#endif /* !OVERLOADED_CONSTANTS */
- QQ(nameEqDouble ) = linkName("primEqDouble");
- QQ(namePmInt ) = linkName("primPmInt");
- ////namePmInteger = linkName("primPmInteger");
- ////namePmDouble = linkName("primPmDouble");
- ////namePmLe = linkName("primPmLe");
- ////namePmSubtract = linkName("primPmSubtract");
- ////namePmFromInteger = linkName("primPmFromInteger");
- ////QQ(nameMap ) = linkName("map");
+ nameEqDouble = linkName("primEqDouble");
+ namePmInt = linkName("primPmInt");
+ name(namePmInt).inlineMe = TRUE;
}
}
/* ToDo: fix pFun (or eliminate its use) */
-#define pFun(n,s) QQ(n) = predefinePrim(s)
+#define pFun(n,s) n = predefinePrim(s)
Void linkControl(what)
Int what; {
pFun(nameComp, ".");
pFun(nameAnd, "&&");
pFun(nameCompAux, "primCompAux");
+ name(nameCompAux).inlineMe = TRUE;
pFun(nameMap, "map");
/* implementTagToCon */
pFun(namePMFail, "primPmFail");
- pFun(namePMFailBUG, "primPmFailBUG");
pFun(nameError, "error");
pFun(nameUnpackString, "primUnpackString");
extern Name nameMkC;
extern Name nameMkI;
-#ifdef PROVIDE_INT64
-extern Name nameMkInt64;
-#endif
-#ifdef PROVIDE_WORD
extern Name nameMkW;
-#endif
-#ifdef PROVIDE_ADDR
extern Name nameMkA;
-#endif
extern Name nameMkF;
extern Name nameMkD;
#ifdef PROVIDE_STABLE
* unpointed values pointed and require no special treatment
* by the code generator.
*/
-#ifdef PROVIDE_INTEGER
extern Name nameMkInteger;
-#endif
-#ifdef PROVIDE_ARRAY
extern Name nameMkPrimArray;
extern Name nameMkPrimByteArray;
extern Name nameMkRef;
extern Name nameMkPrimMutableArray;
extern Name nameMkPrimMutableByteArray;
-#endif
#ifdef PROVIDE_FOREIGN
extern Name nameMkForeign;
#endif
*/
extern Type typeChar;
extern Type typeInt;
-#ifdef PROVIDE_INT64
-extern Type typeInt64;
-#endif
-#ifdef PROVIDE_INTEGER
extern Type typeInteger;
-#endif
-#ifdef PROVIDE_WORD
extern Type typeWord;
-#endif
-#ifdef PROVIDE_ADDR
extern Type typeAddr;
-#endif
-#ifdef PROVIDE_ARRAY
extern Type typePrimArray;
extern Type typePrimByteArray;
extern Type typeRef;
extern Type typePrimMutableArray;
extern Type typePrimMutableByteArray;
-#endif
extern Type typeFloat;
extern Type typeDouble;
#ifdef PROVIDE_STABLE
extern Type typeIO;
extern Type typeException;
-/* copied out of K&R2, Appendix A */
-#define cat(x,y) x ## y
-#define xcat(x,y) cat(x,y)
-
-#ifdef BIGNUMTYPE
-#define typeBignum xcat(type,BIGNUMTYPE)
-#define nameMkBignum xcat(nameMk,BIGNUMTYPE)
-#else
-#warning BIGNUMTYPE undefined
-#endif
-
/* used while desugaring */
extern Name nameId;
extern Name nameOtherwise;
/* used in translation */
extern Name nameEq;
extern Name namePMFail;
-extern Name namePMFailBUG;
extern Name nameEqChar;
extern Name nameEqInt;
extern Name nameEqInteger;
* in the distribution for details.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:49 $
+ * $Revision: 1.5 $
+ * $Date: 1999/04/27 10:06:55 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
/* --------------------------------------------------------------------------
- * Get time/date stamp for inclusion in compiled files:
- * ------------------------------------------------------------------------*/
-
-#if PROFILING
-String timeString() { /* return time&date string */
- time_t clock; /* must end with '\n' character */
- time(&clock);
- return(ctime(&clock));
-}
-#endif
-
-/* --------------------------------------------------------------------------
* Garbage collection notification:
* ------------------------------------------------------------------------*/
fatal("gcCStack");
#endif
-#define StackGrowsDown while (ptr<=CStackBase) markWithoutMove(*ptr++)
-#define StackGrowsUp while (ptr>=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;
#include <errno.h>
#include <assert.h>
#include <malloc.h>
+#include <stdlib.h>
int nh_stdin ( void )
{
return (int)stdout;
}
+int nh_stderr ( void )
+{
+ errno = 0;
+ return (int)stderr;
+}
+
int nh_open ( char* fname, int wr )
{
FILE* f;
fclose ( f );
}
+void nh_flush ( FILE* f )
+{
+ errno = 0;
+ fflush ( f );
+}
+
void nh_write ( FILE* f, int c )
{
errno = 0;
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]);
}
* 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"
#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;
+ }
}
/*-------------------------------------------------------------------------*/
* 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"
}
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));
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;
* 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 $
* ------------------------------------------------------------------------*/
%{
#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
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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;
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+
+/* --------------------------------------------------------------------------
+ * Yet another implementation of Integer
+ *
+ * Copyright (c) Glasgow University, 1999.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * ------------------------------------------------------------------------*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <assert.h>
+#include <ctype.h>
+
+#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
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+
+#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 );
+
* 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
#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 */
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
* 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"
* ------------------------------------------------------------------------*/
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));
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));
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));
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));
/* --------------------------------------------------------------------------
String reloadModule;
#endif
-#if !IGNORE_MODULES
Void startModule(nm) /* switch to a new module */
Cell nm; {
Module m;
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:;
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);
}
}
}
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;
#endif
return es;
}
-#endif
+
/* --------------------------------------------------------------------------
* Static analysis of type declarations:
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<i; n++) {
- t = arg(t);
- }
- checkBanged(c,ks,ctxt,arg(fun(t)));
- }
- }
- }
- }
- }
-}
-
-static List local calcEvalContexts(tc,ts,ps)
-Tycon tc; /* Worker code for deriveEval */
-List ts; /* ts = not visited, ps = visiting */
-List ps; {
- Cell ctxt = NIL;
- Int o = newKindedVars(tycon(tc).kind);
- Type t = tycon(tc).defn;
- Int i;
-
- if (whatIs(tycon(tc).what)==NEWTYPE) {
- t = name(hd(t)).type;
- if (isPolyType(t)) {
- t = monotypeOf(t);
- }
- if (whatIs(t)==QUAL) {
- t = snd(snd(t));
- }
- if (whatIs(t)==EXIST) { /* No instance if existentials used*/
- return ts;
- }
- if (whatIs(t)==RANK2) { /* No instance if arg is poly/qual */
- return ts;
- }
- t = arg(fun(t));
- }
-
- clearMarks(); /* Make sure generics are marked */
- for (i=0; i<tycon(tc).arity; i++) { /* in the correct order. */
- copyTyvar(o+i);
- }
-
- for (;;) {
- Type h = getDerefHead(t,o);
- if (isSynonym(h) && argCount>=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:
* ------------------------------------------------------------------------*/
List ns = NIL; /* List of names */
Int mno; /* Member function number */
- //printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) );
for (mno=0; mno<cclass(c).numSupers; mno++) {
ns = cons(newDSel(c,mno),ns);
}
EEND;
}
- name(m).line = l;
- name(m).arity = 1;
- name(m).number = mfunNo(no);
- name(m).type = t;
- //printf ( " [%d %d] %s :: ", m, m-NAMEMIN, textToStr ( name(m).text ) );
- //printType(stdout, t );
- //printf ( "\n" );
+ name(m).line = l;
+ name(m).arity = 1;
+ name(m).number = mfunNo(no);
+ name(m).type = t;
+ name(m).inlineMe = TRUE;
return m;
}
char buf[16];
sprintf(buf,"sc%d.%s",no,"%s");
- s = newName(generateText(buf,c),c);
- name(s).line = cclass(c).line;
- name(s).arity = 1;
- name(s).number = DFUNNAME;
+ s = newName(generateText(buf,c),c);
+ name(s).line = cclass(c).line;
+ name(s).arity = 1;
+ name(s).number = DFUNNAME;
return s;
}
static Name local newDBuild(c) /* Make definition for builder */
Class c; {
- Name b = newName(generateText("class.%s",c),c);
- name(b).line = cclass(c).line;
- name(b).arity = cclass(c).numSupers+1;
+ Name b = newName(generateText("class.%s",c),c);
+ name(b).line = cclass(c).line;
+ name(b).arity = cclass(c).numSupers+1;
return b;
}
ERRMSG(line) "Illegal predicate in instance declaration"
EEND;
}
-#if EVAL_INSTANCES
- if (inst(in).c==classEval) {
- ERRMSG(line) "Instances of class \"%s\" are generated automatically",
- textToStr(cclass(inst(in).c).text)
- EEND;
- }
-#endif
kindInst(in,length(tyvars));
insertInst(in);
addDerInst(0,c,NIL,cts,mkTuple(n),n);
}
-#if EVAL_INSTANCES
-Void addEvalInst(line,t,arity,ctxt) /* Add dummy instance for Eval */
-Int line;
-Cell t;
-Int arity;
-List ctxt; {
- Inst in = newInst();
- Cell head = t;
- Int i;
- for (i=0; i<arity; i++) {
- head = ap(head,mkOffset(i));
- }
- inst(in).line = line;
- inst(in).c = classEval;
- inst(in).head = ap(classEval,head);
- inst(in).specifics = ctxt;
- inst(in).builder = newInstImp(in);
- inst(in).numSpecifics = length(ctxt);
- kindInst(in,arity);
- cclass(classEval).instances
- = appendOnto(cclass(classEval).instances,singleton(in));
-}
-#endif
-
#if TREX
Inst addRecShowInst(c,e) /* Generate instance for ShowRecRow*/
Class c; /* c *must* be ShowRecRow */
case CONIDCELL :
case CONOPCELL : return checkApPat(line,0,p);
-#if BIGNUMS
- case ZERONUM :
- case POSNUM :
- case NEGNUM :
-#endif
case WILDCARD :
case STRCELL :
case CHARCELL :
if (nneg&1) /* for literals */
arg(temp) = mkInt(-intOf(arg(temp)));
}
-#if BIGNUMS
- else if (isBignum(arg(temp))) {
- if (nneg&1)
- arg(temp) = bigNeg(arg(temp));
- }
-#endif
else if (isFloat(arg(temp))) {
if (nneg&1)
arg(temp) = floatNegate(arg(temp));
mapProc(addDepField,bs); /* add extra field for dependents */
for (xs=bs; nonNull(xs); xs=tl(xs)) {
-
- //Printf("\n-----------------------------------------\n" ); print(hd(xs),1000); Printf("\n");
-
emptySubstitution();
depBinding(hd(xs));
soFar((Target)(i++));
break;
#endif
-#if BIGNUMS
- case ZERONUM :
- case POSNUM :
- case NEGNUM :
-#endif
case NAME :
case TUPLE :
case STRCELL :
case CHARCELL :
case FLOATCELL :
+ case BIGCELL :
case INTCELL : break;
case COND : depTriple(line,snd(e));
EEND;
}
-#if !IGNORE_MODULES
if (!moduleThisScript(name(n).mod)) {
return n;
}
-#endif
/* Later phases of the system cannot cope if we resolve references
* to unprocessed objects too early. This is the main reason that
* we cannot cope with recursive modules at the moment.
ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
EEND;
}
-#if !IGNORE_MODULES
if (name(n).mod != currentModule) {
return n;
}
-#endif
if (fst(e) == VARIDCELL) {
e = mkVar(qtextOf(e));
} else {
}
Void checkDefns() { /* Top level static analysis */
-#if !IGNORE_MODULES
Module thisModule = lastModule();
-#endif
staticAnalysis(RESET);
-#if !IGNORE_MODULES
setCurrModule(thisModule);
/* Resolve module references */
module(thisModule).qualImports);
}
mapProc(checkImportList, unqualImports);
-#endif
linkPreludeTC(); /* Get prelude tycons and classes */
mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */
setCurrModule(thisModule);
mapProc(addDerivImp,derivedInsts); /* Add impls for derived instances */
deriveContexts(derivedInsts); /* Calculate derived inst contexts */
-#if EVAL_INSTANCES
- deriveEval(tyconDefns); /* Derive instances of Eval */
-#endif
instDefns = appendOnto(instDefns,derivedInsts);
checkDefaultDefns(); /* validate default definitions */
mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
-#if 0 /* from STG */
- valDefns = eqnsToBindings(valDefns);/* translate value equations */
- map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound */
-#else /* from 98 */
valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns, NIL/*primDefns*/ );
tyconDefns = NIL;
- /* primDefns = NIL; */
-#endif
+
mapProc(allNoPrevDef,valDefns); /* check against previous defns */
linkPreludeNames();
foreignImports = NIL;
foreignExports = NIL;
-#if !IGNORE_MODULES
/* Every top-level name has now been created - so we can build the */
/* export list. Note that this has to happen before dependency */
/* analysis so that references to Prelude.foo will be resolved */
/* when compiling the prelude. */
module(thisModule).exports = checkExports(module(thisModule).exports);
-#endif
mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
name(n).line = line;
}
-#if IGNORE_MODULES
-static Void local duplicateErrorAux(line,t,kind) /* report duplicate defn */
-Int line;
-Text t;
-String kind; {
- ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
- textToStr(t)
- EEND;
-}
-#else /* !IGNORE_MODULES */
static Void local duplicateErrorAux(line,mod,t,kind)/* report duplicate defn */
Int line;
Module mod;
EEND;
}
}
-#endif /* !IGNORE_MODULES */
static Void local checkTypeIn(cvs) /* Check that vars in restricted */
Pair cvs; { /* synonym are defined */
* Hugs version 1.4, December 1997
*
* $RCSfile: stg.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/09 14:51:13 $
+ * $Revision: 1.6 $
+ * $Date: 1999/04/27 10:07:04 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
* Utility functions
* ------------------------------------------------------------------------*/
-int stgConTag( StgDiscr d )
-{
- switch (whatIs(d)) {
- case NAME:
- return cfunOf(d);
- case TUPLE:
- return 0;
- default:
- internal("stgConTag");
- }
-}
-
void* stgConInfo( StgDiscr d )
{
switch (whatIs(d)) {
}
}
-/* ToDo: identical to stgConTag */
int stgDiscrTag( StgDiscr d )
{
switch (whatIs(d)) {
Bool isStgVar(e)
StgRhs e; {
- //printf("{%d %d %d} ", namePMFail, e, whatIs(e) );
switch (whatIs(e)) {
case STGVAR:
return TRUE;
return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
}
-/*-------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* STG pretty printer
- *
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
- *
- * $RCSfile: stg.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/09 14:51:13 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
static Void local putStgBinds Args((List));
static Void local putStgExpr Args((StgExpr));
static Void local putStgRhs Args((StgRhs));
-static Void local putStgPat Args((StgPat));
-static Void local putStgPrimPat Args((StgPrimPat));
+static Void local putStgPat Args((StgCaseAlt));
+static Void local putStgPrimPat Args((StgPrimAlt));
+
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
static Void putStgAlts ( Int left, List alts );
-//static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
static Void local putStgVar(StgVar v)
{
if (isName(v)) {
+ if (name(v).inlineMe) putStr("IL__");
unlexVar(name(v).text);
} else {
putStr("id");
putInt(-v);
+ putStr("<");
+ putChr(charOf(stgVarRep(v)));
+ putStr(">");
+ if (isInt(stgVarInfo(v))) {
+ putStr("(");
+ putInt(intOf(stgVarInfo(v)));
+ putStr(")");
+ }
}
}
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");
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:
{
fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
internal("putStgPrimPat");
}
+ } else {
+ putStgVar(v);
}
putChr(' ');
}
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);
if (length(alts) == 1) {
StgPrimAlt alt = hd(alts);
putStr("{ ");
- mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ mapProc(putStgPrimPat,stgPrimAltVars(alt));
putStr(" ->\n");
pIndent(left);
putStgExpr(stgPrimAltBody(alt));
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");
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;
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;
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); */
}
}
static void beginStgPP( FILE* fp )
{
outputStream = fp;
- //putChr('\n');
outColumn = 0;
+ fflush(stderr); fflush(stdout);
}
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");
#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
* 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"
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 )
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);
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;
+}
+
+
+
/*-------------------------------------------------------------------------*/
* 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"
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));
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:
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;
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;
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;
return fst(e);
}
return NIL;
-#endif /* !IGNORE_MODULES */
}
default : internal("findQualTycon2");
}
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++;
}
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;
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;
}
}
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:
* ------------------------------------------------------------------------*/
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++;
}
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
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;
if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
return fst(e);
}
-#endif
}
return NIL;
}
*
* ------------------------------------------------------------------------*/
-#if !IGNORE_MODULES
static Module moduleHw; /* next unused Module */
struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */
Module currentModule; /* Module currently being processed*/
classes = module(m).classes;
}
}
-#endif /* !IGNORE_MODULES */
/* --------------------------------------------------------------------------
* Script file storage:
Text textHw;
Text nextNewText;
Text nextNewDText;
-#if !IGNORE_MODULES
Module moduleHw;
-#endif
Tycon tyconHw;
Name nameHw;
Class classHw;
}
#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);
showUse("Ext", extHw-EXTMIN, NUM_EXT);
#endif
#endif
-
scripts[scriptHw].file = findText( f ? f : "<nofile>" );
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;
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;
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; { \
return (s==0) ? modulePrelude : scripts[s-1].moduleHw;
}
-#if !IGNORE_MODULES
String fileOfModule(m)
Module m; {
Script s;
}
return 0;
}
-#endif
Script scriptThisFile(f)
Text f; {
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;
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);
textHash[i][j] = NOTEXT;
}
-#if IGNORE_MODULES
- for (i=0; i<TYCONHSZ; ++i) {
- Tycon tc = tyconHash[i];
- while (nonNull(tc) && tc>=tyconHw)
- tc = tycon(tc).nextTyconHash;
- tyconHash[i] = tc;
- }
-
- for (i=0; i<NAMEHSZ; ++i) {
- Name n = nameHash[i];
- while (nonNull(n) && n>=nameHw)
- n = name(n).nextNameHash;
- nameHash[i] = n;
- }
-#else /* !IGNORE_MODULES */
currentModule=NIL;
for (i=0; i<TYCONHSZ; ++i) {
tyconHash[i] = NIL;
for (i=0; i<NAMEHSZ; ++i) {
nameHash[i] = NIL;
}
-#endif /* !IGNORE_MODULES */
for (i=CLASSMIN; i<classHw; i++) {
List ins = cclass(i).instances;
#endif
Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
-#if PROFILING
-Heap heapThd, heapTopThd; /* to keep record of producers */
-Int sysCount; /* record unattached cells */
-Name producer; /* current producer, if any */
-Bool profiling = FALSE; /* should profiling be performed */
-Int profInterval = MAXPOSINT; /* interval between samples */
-FILE *profile = 0; /* pointer to profiler log, if any */
-#endif
Long numCells;
Int numGcs; /* number of garbage collections */
Int cellsRecovered; /* number of cells recovered */
static Cell freeList; /* free list of unused cells */
static Cell lsave, rsave; /* save components of pair */
-#if GC_WEAKPTRS
-static List weakPtrs; /* list of weak ptrs */
- /* reconstructed during every GC */
-List finalizers = NIL;
-List liveWeakPtrs = NIL;
-#endif
-
#if GC_STATISTICS
static Int markCount, stackRoots;
freeList = snd(freeList);
fst(c) = l;
snd(c) = r;
-#if PROFILING
- thd(c) = producer;
-#endif
numCells++;
return c;
}
Int recovered;
jmp_buf regs; /* save registers on stack */
-printf("\n\n$$$$$$$$$$$ GARBAGE COLLECTION; aborting\n\n");
-exit(1);
setjmp(regs);
gcStarted();
for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
marks[i] = 0;
-#if GC_WEAKPTRS
- weakPtrs = NIL; /* clear list of weak pointers */
-#endif
- everybody(MARK); /* Mark all components of system */
-
-#if IO_HANDLES
- for (i=0; i<NUM_HANDLES; ++i) /* release any unused handles */
- if (nonNull(handles[i].hcell)) {
- register place = placeInSet(handles[i].hcell);
- register mask = maskInSet(handles[i].hcell);
- if ((marks[place]&mask)==0)
- freeHandle(i);
- }
-#endif
-#if GC_MALLOCPTRS
- for (i=0; i<NUM_MALLOCPTRS; ++i) /* release any unused mallocptrs */
- if (isPair(mallocPtrs[i].mpcell)) {
- register place = placeInSet(mallocPtrs[i].mpcell);
- register mask = maskInSet(mallocPtrs[i].mpcell);
- if ((marks[place]&mask)==0)
- incMallocPtrRefCnt(i,-1);
- }
-#endif /* GC_MALLOCPTRS */
-#if GC_WEAKPTRS
- /* After GC completes, we scan the list of weak pointers that are
- * still live and zap their contents unless the contents are still
- * live (by some other means).
- * Note that this means the contents must itself be heap allocated.
- * This means it can't be a nullary constructor or an Int or a Name
- * or lots of other things - hope this doesn't bite too hard.
- */
- for (; nonNull(weakPtrs); weakPtrs=nextWeakPtr(weakPtrs)) {
- Cell ptr = derefWeakPtr(weakPtrs);
- if (isGenPair(ptr)) {
- Int place = placeInSet(ptr);
- Int mask = maskInSet(ptr);
- if ((marks[place]&mask)==0) {
- /* printf("Zapping weak pointer %d\n", ptr); */
- derefWeakPtr(weakPtrs) = NIL;
- } else {
- /* printf("Keeping weak pointer %d\n", ptr); */
- }
- } else if (nonNull(ptr)) {
- printf("Weak ptr contains object which isn't heap allocated %d\n", ptr);
- }
- }
-
- if (nonNull(liveWeakPtrs) || nonNull(finalizers)) {
- Bool anyMarked; /* Weak pointers with finalizers */
- List wps;
- List newFins = NIL;
-
- /* Step 1: iterate until we've found out what is reachable */
- do {
- anyMarked = FALSE;
- for (wps=liveWeakPtrs; nonNull(wps); wps=tl(wps)) {
- Cell wp = hd(wps);
- Cell k = fst(snd(wp));
- if (isNull(k)) {
- internal("bad weak ptr");
- }
- if (isMarked(k)) {
- Cell vf = snd(snd(wp));
- if (!isMarked(fst(vf)) || !isMarked(snd(vf))) {
- mark(fst(vf));
- mark(snd(vf));
- anyMarked = TRUE;
- }
- }
- }
- } while (anyMarked);
-
- /* Step 2: Now we know which weak pointers will die, so we can */
- /* remove them from the live set and gather their finalizers. But */
- /* note that we mustn't mark *anything* at this stage or we will */
- /* corrupt our view of what's alive, and what's dead. */
- wps = NIL;
- while (nonNull(liveWeakPtrs)) {
- Cell wp = hd(liveWeakPtrs);
- List nx = tl(liveWeakPtrs);
- Cell k = fst(snd(wp));
- if (!isMarked(k)) { /* If the key is dead, then*/
- Cell vf = snd(snd(wp)); /* stomp on weak pointer */
- fst(vf) = snd(vf);
- snd(vf) = newFins;
- newFins = vf; /* reuse because we can't */
- fst(snd(wp)) = NIL; /* reallocate here ... */
- snd(snd(wp)) = NIL;
- snd(wp) = NIL;
- liveWeakPtrs = nx;
- } else {
- tl(liveWeakPtrs) = wps; /* Otherwise, weak pointer */
- wps = liveWeakPtrs;/* survives to face another*/
- liveWeakPtrs = nx; /* garbage collection */
- }
- }
- /* Step 3: Now we've identified the live cells and the newly */
- /* scheduled finalizers, but we had better make sure that they are */
- /* all marked now, including any internal structure, to ensure that*/
- /* they make it to the other side of gc. */
- for (liveWeakPtrs=wps; nonNull(wps); wps=tl(wps)) {
- mark(snd(hd(wps)));
- }
- mark(liveWeakPtrs);
- mark(newFins);
- finalizers = revOnto(newFins,finalizers);
- }
+ everybody(MARK); /* Mark all components of system */
-#endif /* GC_WEAKPTRS */
gcScanning(); /* scan mark set */
mask = 1;
place = 0;
recovered = 0;
j = 0;
-#if PROFILING
- if (profile) {
- sysCount = 0;
- for (i=NAMEMIN; i<nameHw; i++)
- name(i).count = 0;
- }
-#endif
+
freeList = NIL;
for (i=1; i<=heapSize; i++) {
if ((marks[place] & mask) == 0) {
freeList = -i;
recovered++;
}
-#if PROFILING
- else if (nonNull(thd(-i)))
- name(thd(-i)).count++;
- else
- sysCount++;
-#endif
mask <<= 1;
if (++j == bitsPerWord) {
place++;
gcRecovered(recovered);
breakOn(breakStat); /* restore break trapping if nec. */
-#if PROFILING
- if (profile) {
- fprintf(profile,"BEGIN_SAMPLE %ld.00\n",numReductions);
-/* For the time being, we won't include the system count in the output:
- if (sysCount>0)
- fprintf(profile," SYSTEM %d\n",sysCount);
-*/
- /* Accumulate costs in top level objects */
- for (i=NAMEMIN; i<nameHw; i++) {
- Name cc = i;
- /* Use of "while" instead of "if" is pure paranoia - ADR */
- while (isName(name(cc).parent))
- cc = name(cc).parent;
- if (i != cc) {
- name(cc).count += name(i).count;
- name(i).count = 0;
- }
- }
- for (i=NAMEMIN; i<nameHw; i++)
- if (name(i).count>0)
- 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<minRecovery || isNull(freeList)) {
cellsRecovered = recovered;
}
-#if PROFILING
-Void profilerLog(s) /* turn heap profiling on, saving log*/
-String s; { /* in specified file */
- if ((profile=fopen(s,"w")) != NULL) {
- fprintf(profile,"JOB \"Hugs Heap Profile\"\n");
- fprintf(profile,"DATE \"%s\"\n",timeString());
- fprintf(profile,"SAMPLE_UNIT \"reductions\"\n");
- fprintf(profile,"VALUE_UNIT \"cells\"\n");
- }
- else {
- ERRMSG(0) "Cannot open profile log file \"%s\"", s
- EEND;
- }
-}
-#endif
-
/* --------------------------------------------------------------------------
* Code for saving last expression entered:
*
Int intOf(c) /* find integer value of cell? */
Cell c; {
- assert(isInt(c));
+ if (!isInt(c)) {
+ assert(isInt(c)); }
return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
}
: pair(INTCELL,n);
}
-#if BIGNUMS
-Bool isBignum(c) /* cell holds bignum value? */
-Cell c; {
- return c==ZERONUM || (isPair(c) && (fst(c)==POSNUM || fst(c)==NEGNUM));
-}
-#endif
-
#if SIZEOF_INTP == SIZEOF_INT
typedef union {Int i; Ptr p;} IntOrPtr;
Cell mkPtr(p)
return ys;
}
-#if 0
-List delete(xs,y) /* Delete first use of y from xs */
-List xs;
-Cell y; {
- if (isNull(xs)) {
- return xs;
- } else if (hs(xs) == y) {
- return tl(xs);
- } else {
- tl(xs) = delete(tl(xs),y);
- return xs;
- }
-}
-
-List minus(xs,ys) /* Delete members of ys from xs */
-List xs, ys; {
- mapAccum(delete,xs,ys);
- return xs;
-}
-#endif
-
Cell varIsMember(t,xs) /* Test if variable is a member of */
Text t; /* given list of variables */
List xs; {
return f;
}
-/* --------------------------------------------------------------------------
- * Handle operations:
- * ------------------------------------------------------------------------*/
-
-#if IO_HANDLES
-struct strHandle DEFTABLE(handles,NUM_HANDLES);
-
-Cell openHandle(s,hmode,binary) /* open handle to file named s in */
-String s; /* the specified hmode */
-Int hmode;
-Bool binary; {
- Int i;
-
- for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
- ; /* Search for unused handle*/
- if (i>=NUM_HANDLES) { /* If at first we don't */
- garbageCollect(); /* succeed, garbage collect*/
- for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
- ; /* and try again ... */
- }
- if (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 && n<NUM_HANDLES && nonNull(handles[n].hcell)) {
- if (n>HSTDERR && 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 && mallocPtrs[i].refCount!=0; ++i)
- ; /* Search for unused entry */
- if (i>=NUM_MALLOCPTRS) { /* If at first we don't */
- garbageCollect(); /* succeed, garbage collect*/
- for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
- ; /* and try again ... */
- }
- if (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<NUM_MALLOCPTRS && mallocPtrs[n].refCount > 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
*/
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<NUM_MALLOCPTRS; i++)
- mallocPtrs[i].mpcell = NIL;
-#endif
-#if !HSCRIPT
-#if GC_STABLEPTRS
- resetStablePtrs();
-#endif
-#endif
consGC = TRUE;
lsave = NIL;
rsave = NIL;
}
end("Names", nameHw-NAMEMIN);
-#if !IGNORE_MODULES
start();
for (i=MODMIN; i<moduleHw; ++i) {
mark(module(i).tycons);
mark(module(i).qualImports);
}
end("Modules", moduleHw-MODMIN);
-#endif
start();
for (i=TYCMIN; i<tyconHw; ++i) {
mark(lsave);
mark(rsave);
end("Last expression", 3);
-#if IO_HANDLES
- start();
- mark(handles[HSTDIN].hcell);
- mark(handles[HSTDOUT].hcell);
- mark(handles[HSTDERR].hcell);
- end("Standard handles", 3);
-#endif
-
-#if GC_STABLEPTRS
- start();
- for (i=0; i<NUM_STABLEPTRS; ++i)
- mark(stablePtrTable[i]);
- end("Stable pointers", NUM_STABLEPTRS);
-#endif
-
-#if GC_WEAKPTRS
- mark(finalizers);
-#endif
if (consGC) {
start();
heapTopFst = heapFst + heapSize;
heapTopSnd = heapSnd + heapSize;
-#if PROFILING
- heapThd = heapAlloc(heapSize);
- if (heapThd==(Heap)0) {
- ERRMSG(0) "Cannot allocate profiler storage space"
- EEND;
- }
- heapTopThd = heapThd + heapSize;
- profile = 0;
- if (0 == profInterval)
- profInterval = heapSize / DEF_PROFINTDIV;
-#endif
for (i=1; i<heapSize; ++i) {
fst(-i) = FREECELL;
snd(-i) = -(i+1);
#endif
clearStack();
-#if IO_HANDLES
- TABALLOC(handles, struct strHandle, NUM_HANDLES)
- for (i=0; i<NUM_HANDLES; i++)
- handles[i].hcell = NIL;
- handles[HSTDIN].hcell = ap(HANDCELL,HSTDIN);
- handles[HSTDIN].hfp = stdin;
- handles[HSTDOUT].hcell = ap(HANDCELL,HSTDOUT);
- handles[HSTDOUT].hfp = stdout;
- handles[HSTDERR].hcell = ap(HANDCELL,HSTDERR);
- handles[HSTDERR].hfp = stderr;
-#endif
-
textHw = 0;
nextNewText = NUM_TEXT;
nextNewDText = (-1);
textHash[i][0] = NOTEXT;
-#if !IGNORE_MODULES
moduleHw = MODMIN;
-#endif
tyconHw = TYCMIN;
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
-
-#if GC_WEAKPTRS
- finalizers = NIL;
- liveWeakPtrs = NIL;
-#endif
-
-#if GC_STABLEPTRS
- resetStablePtrs();
-#endif
-
#if TREX
extHw = EXTMIN;
#endif
* in the distribution for details.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/09 14:51:14 $
+ * $Revision: 1.6 $
+ * $Date: 1999/04/27 10:07:06 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
#define fst(c) heapTopFst[c]
#define snd(c) heapTopSnd[c]
-#if PROFILING
-extern Heap heapThd, heapTopThd;
-#define thd(c) heapTopThd[c]
-extern Name producer;
-extern Bool profiling;
-extern Int profInterval;
-extern Void profilerLog Args((String));
-#endif
extern Pair pair Args((Cell,Cell));
extern Void garbageCollect Args((Void));
#define mkFloat(f) (f) /* ToDo: is this right? */
#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
+#define stringToBignum(s) pair(BIGCELL,findText(s))
#define bignumToString(b) textToStr(snd(b))
#define FLOATCELL 36 /* FLOATCELL snd :: (Int,Int) */
#endif
-#if BIGNUMS
-#define POSNUM 37 /* POSNUM snd :: [Int] */
-#define NEGNUM 38 /* NEGNUM snd :: [Int] */
-#endif
-
#define BOOLQUAL 39 /* BOOLQUAL snd :: Exp */
#define QWHERE 40 /* QWHERE snd :: [Decl] */
#define FROMQUAL 41 /* FROMQUAL snd :: (Exp,Exp) */
#define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
#define STGCON 95 /* STGCON snd :: (StgCon,[Arg]) */
#define PRIMCASE 96 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
+#define DEEFALT 97 /* DEEFALT snd :: (Var,Expr) */
+#define CASEALT 98 /* CASEALT snd :: (Con,[Var],Expr) */
+#define PRIMALT 99 /* PRIMALT snd :: ([Var],Expr) */
/* Last constructor tag must be less than SPECMIN */
/* --------------------------------------------------------------------------
#define DOTDOT 106 /* ".." in import/export list */
-#if BIGNUMS
-#define ZERONUM 108 /* The zero bignum (see POSNUM, NEGNUM) */
-#endif
-
#define NAME 110 /* whatIs code for isName */
#define TYCON 111 /* whatIs code for isTycon */
#define CLASS 112 /* whatIs code for isClass */
#define MODMIN (OFFMIN+NUM_OFFSETS)
-#if IGNORE_MODULES
-#define setCurrModule(m) doNothing()
-#else /* !IGNORE_MODULES */
#define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
#define mkModule(n) (MODMIN+(n))
#define module(n) tabModule[(n)-MODMIN]
extern Void setCurrModule Args((Module));
#define isPrelude(m) (m==modulePrelude)
-#endif /* !IGNORE_MODULES */
/* --------------------------------------------------------------------------
* Type constructor names:
struct strTycon {
Text text;
Int line;
-#if !IGNORE_MODULES
Module mod; /* module that defines it */
-#endif
Int arity;
Kind kind; /* kind (includes arity) of Tycon */
Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
Cell type;
Cell defn;
Cell stgVar; /* really StgVar */
+ Int stgSize; /* == stgSize(stgVarBody(.stgVar)) */
+ Bool inlineMe; /* self-evident */
+ Bool simplified; /* TRUE => already simplified */
+ Bool isDBuilder; /* TRUE => is a dictionary builder */
const void* primop; /* really StgPrim* */
Name nextNameHash;
};
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:
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 */
#define MAXCHARVAL (NUM_CHARS-1)
#define isChar(c) (CHARMIN<=(c) && (c)<INTMIN)
#define charOf(c) ((Char)(c-CHARMIN))
-#define mkChar(c) ((Cell)(CHARMIN+((unsigned)((c)%NUM_CHARS))))
+#define mkChar(c) ((Cell)(CHARMIN+(((unsigned)(c))%NUM_CHARS)))
/* --------------------------------------------------------------------------
* Small Integer values:
extern Bool isInt Args((Cell));
extern Int intOf Args((Cell));
extern Cell mkInt Args((Int));
-#if BIGNUMS
-extern Bool isBignum Args((Cell));
-#endif
/* --------------------------------------------------------------------------
* Implementation of triples:
extern String fileOfModule Args((Module));
extern Void dropScriptsFrom Args((Script));
-/* --------------------------------------------------------------------------
- * I/O Handles:
- * ------------------------------------------------------------------------*/
-
-#if IO_HANDLES
-#define HSTDIN 0 /* Numbers for standard handles */
-#define HSTDOUT 1
-#define HSTDERR 2
-
-struct strHandle { /* Handle description and status flags */
- Cell hcell; /* Heap representation of handle (or NIL) */
- FILE *hfp; /* Corresponding file pointer */
- Int hmode; /* Current mode: see below */
-};
-
-#define HCLOSED 0000 /* no I/O permitted */
-#define HSEMICLOSED 0001 /* semiclosed reads only */
-#define HREAD 0002 /* set to enable reads from handle */
-#define HWRITE 0004 /* set to enable writes to handle */
-#define HAPPEND 0010 /* opened in append mode */
-
-extern Cell openHandle Args((String,Int,Bool));
-extern struct strHandle DECTABLE(handles);
-#endif
-
-/* --------------------------------------------------------------------------
- * Malloc Pointers
- * ------------------------------------------------------------------------*/
-
-#if GC_MALLOCPTRS
-struct strMallocPtr { /* Malloc Ptr description */
- Cell mpcell; /* Back pointer to MPCELL */
- Void *ptr; /* Pointer into C world */
- Int refCount; /* Reference count */
- Void (*cleanup) Args((Void *)); /* Code to free the C pointer */
-};
-
-extern struct strMallocPtr mallocPtrs[];
-extern Cell mkMallocPtr Args((Void *, Void (*)(Void *)));
-extern Void freeMallocPtr Args((Cell));
-extern Void incMallocPtrRefCnt Args((Int, Int));
-
-#define mpOf(c) snd(c)
-#define derefMP(c) (mallocPtrs[(Int)mpOf(c)].ptr)
-#endif /* GC_MALLOCPTRS */
-
-/* --------------------------------------------------------------------------
- * Weak Pointers
- * ------------------------------------------------------------------------*/
-
-#if GC_WEAKPTRS
-#define mkWeakPtr(c) pair(WEAKCELL,pair(c,NIL))
-#define derefWeakPtr(c) fst(snd(c))
-#define nextWeakPtr(c) snd(snd(c))
-
-extern List finalizers;
-extern List liveWeakPtrs;
-
-#endif /* GC_WEAKPTRS */
-
-/* --------------------------------------------------------------------------
- * Stable pointers
- * ------------------------------------------------------------------------*/
-
-#if GC_STABLEPTRS
-extern Int mkStablePtr Args((Cell));
-extern Cell derefStablePtr Args((Int));
-extern Void freeStablePtr Args((Int));
-#endif /* GC_STABLEPTRS */
/* --------------------------------------------------------------------------
* Plugins
* in the distribution for details.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:56 $
+ * $Revision: 1.5 $
+ * $Date: 1999/04/27 10:07:07 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
}
-#if IO_MONAD
-Bool isProgType(ks,type) /* Test if type is of the form */
-List ks; /* IO t for some t. */
-Type type; {
- Bool result;
- Int alpha;
- Int beta;
- if (isPolyType(type) || whatIs(type)==QUAL)
- return FALSE;
- emptySubstitution();
- alpha = newKindedVars(ks);
- beta = newTyvars(1);
- bindOnlyAbove(beta);
- result = unify(type,alpha,typeProgIO,beta);
- unrestrictBind();
- emptySubstitution();
- return result;
-}
-#endif
/* --------------------------------------------------------------------------
* Matching predicates:
* Hugs version 1.4, December 1997
*
* $RCSfile: translate.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/03/09 14:51:15 $
+ * $Revision: 1.7 $
+ * $Date: 1999/04/27 10:07:08 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "dynamic.h"
#include "Assembler.h"
+
/* ---------------------------------------------------------------- */
static StgVar local stgOffset Args((Offset,List));
case INTCELL:
return mkStgCon(nameMkI,singleton(e));
case BIGCELL:
- return mkStgCon(nameMkBignum,singleton(e));
+ return mkStgCon(nameMkInteger,singleton(e));
case FLOATCELL:
return mkStgCon(nameMkD,singleton(e));
case STRCELL:
return mkStgApp(nameUnpackString,singleton(e));
#endif
case AP:
- return stgExpr(e,co,sc,namePMFailBUG);
+ return stgExpr(e,co,sc,namePMFail);
case NIL:
internal("stgRhs2");
default:
StgVar dIntegral = NIL;
/* bind dictionary */
- dIntegral = stgRhs(dictIntegral,co,sc,namePMFailBUG);
+ dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
if (!isAtomic(dIntegral)) { /* wasn't atomic */
dIntegral = mkStgVar(dIntegral,NIL);
binds = cons(dIntegral,binds);
}
/* box number */
- n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
+ n = mkStgVar(mkStgCon(nameMkInteger,singleton(n)),NIL);
binds = cons(n,binds);
/* coerce number to right type (using Integral dict) */
//StgExpr m = NIL;
Name box
= h == nameFromInt ? nameMkI
- : h == nameFromInteger ? nameMkBignum
+ : h == nameFromInteger ? nameMkInteger
: nameMkD;
Name testFun
= h == nameFromInt ? namePmInt
altsc = cons(pair(mkOffset(co+i),nv),altsc);
}
/* bind dictionary */
- d = stgRhs(dict,co,sc,namePMFailBUG);
+ d = stgRhs(dict,co,sc,namePMFail);
if (!isAtomic(d)) { /* wasn't atomic */
d = mkStgVar(d,NIL);
binds = cons(d,binds);
for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
Cell rhs = hd(bs);
Cell nv = hd(vs);
- stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFailBUG);
+ stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
}
- return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFailBUG*/));
+ return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
}
default: /* convert to an StgApp or StgVar plus some bindings */
{
/* Arguments must be StgAtoms */
for(as=args; nonNull(as); as=tl(as)) {
- StgRhs a = stgRhs(hd(as),co,sc,namePMFailBUG);
+ StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
#if 1 /* optional flattening of let bindings */
if (whatIs(a) == LETREC) {
binds = appendOnto(stgLetBinds(a),binds);
}
/* Function must be StgVar or Name */
- e = stgRhs(e,co,sc,namePMFailBUG);
+ e = stgRhs(e,co,sc,namePMFail);
if (!isStgVar(e) && !isName(e)) {
e = mkStgVar(e,NIL);
binds = cons(e,binds);
{
List vs = NIL;
List sc = NIL;
- Int i;
-#if 0
- if (lastModule() != modulePrelude) {
- fprintf(stderr, "\n===========================================\n" );
- ppExp ( n,arity,e);
- printf("\n\n"); fflush(stdout);
- }
-#endif
+ Int i, s;
for (i = 1; i <= arity; ++i) {
Cell nv = mkStgVar(NIL,NIL);
vs = cons(nv,vs);
}
stgVarBody(name(n).stgVar)
= makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
-#if 0
- if (lastModule() != modulePrelude) {
- ppStg(name(n).stgVar);
- fprintf(stderr, "\n\n");
+ s = stgSize(stgVarBody(name(n).stgVar));
+ name(n).stgSize = s;
+ if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) {
+ name(n).inlineMe = TRUE;
}
- //printStg(stdout, name(n).stgVar);
-#endif
}
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict comps. */
Int a = name(c).arity;
- //fprintf ( stderr,"implementCfun %s\n", textToStr(name(c).text) );
+
if (a > 0) {
StgVar vcurr, e1, v, vsi;
List args = makeArgs(a);
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");
}
{
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) {
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);
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
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 */
}
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 */
}
}
internal("implementForeignExport: not implemented");
}
+// ToDo: figure out how to set inlineMe for these (non-Name) things
Void implementTuple(size)
Int size; {
if (size > 0) {
* 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"
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 */
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,
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);
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);
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;
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);
}
args = tl(args);
genDefns = cons(hd(mems),genDefns);
}
-//printf("done\n" );
}
static Void local typeInstDefn(in) /* Type check implementations of */
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);
}
tooGeneral(line,mem,rt,t);
if (nonNull(preds))
cantEstablish(line,wh,mem,t,ps);
-//printf("done\n" );
}
/* --------------------------------------------------------------------------
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 )
{
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());
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);
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);
fn(aVar,
fn(listof,
listof))));
+ name(nameNil).parent =
+ name(nameCons).parent = typeList;
+
name(nameCons).syntax
= mkSyntax(RIGHT_ASS,5);
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;
}
}
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} ----------------------------------------
instance Integral Integer where
quotRem = primQuotRemInteger
- divMod = primDivModInteger
+ --divMod = primDivModInteger
toInteger = id
toInt = primIntegerToInt
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
instance Show Integer where
showsPrec = showSigned showInt
+
-- Standard Floating types --------------------------------------------------
data Float -- builtin datatype of single precision floating point numbers
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 --------------------------------------------------
-- 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'
-- 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
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)
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 ->
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 ->
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 ->
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
= 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 --------------------------------------------------------------------
------------------------------------------------------------------------------
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
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))
------------------------------------------------------------------------------
--- Addr, ForeignObj, Prim*Array ----------------------------------------------
+-- Word, Addr, ForeignObj, Prim*Array ----------------------------------------
------------------------------------------------------------------------------
data Addr
(>) = 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
data PrimMutableByteArray s
+
------------------------------------------------------------------------------
-- hooks to call libHS_cbits -------------------------------------------------
------------------------------------------------------------------------------
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 ->
(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)
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]]
+
* 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.
* 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"
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 )
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 )
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 )
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);
}
bco->stgexpr = e;
bco->max_sp = bco->sp = 0;
bco->max_hp = bco->hp = 0;
+ bco->lastOpc = i_INTERNAL_ERROR;
return 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);
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);
}
*
* ------------------------------------------------------------------------*/
+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 );
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
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 */
}
}
+
+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);
}
{
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);
}
int offset;
if (rep == VOID_REP) {
- emit_i0(bco,i_VOID);
+ emiti_(bco,i_VOID);
bco->sp += repSizeW(rep);
return;
}
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;
break;
#endif
-#ifdef PROVIDE_INTEGER
case INTEGER_REP:
-#endif
#ifdef PROVIDE_WEAK
case WEAK_REP:
#endif
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 */
emit_i_SLIDE(bco,x,y);
bco->sp -= sp1 - sp2;
}
- emit_i0(bco,i_ENTER);
+ emiti_(bco,i_ENTER);
}
/* --------------------------------------------------------------------------
{
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
{
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:
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
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 )
{
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;
}
{
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;
}
void asmPanic( AsmBCO bco )
{
- emit_i0(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
+ emiti_(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
}
/* --------------------------------------------------------------------------
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;
}
, { "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 }
, { "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 }
, { "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 }
/* 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 }
/* 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 }
, { "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 }
, { "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 }
, { "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 }
, { "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 }
, { "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 }
/* {new,write,read,index}ForeignObjArray not provided */
-#endif PROVIDE_ARRAY
#ifdef PROVIDE_FOREIGN
/* ForeignObj# operations */
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;
}
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;
}
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);
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));
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;
}
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;
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;
}
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;
}
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
/* -----------------------------------------------------------------------------
- * $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
*
* 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 */
, 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
, i_shiftRLWord
, i_intToWord
, i_wordToInt
-#endif
-#ifdef PROVIDE_ADDR
+
/* Addr# operations */
, i_gtAddr
, i_geAddr
/* 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
, 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
, 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
, 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
, 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
, 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
, i_raise
-#ifdef PROVIDE_ARRAY
/* Ref operations */
, i_newRef
, i_writeRef
, 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
/* {write,read,index}ForeignObjArray not provided */
-#endif /* PROVIDE_ARRAY */
-
#ifdef PROVIDE_PTREQUALITY
, i_reallyUnsafePtrEquality
#endif
* 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"
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;
}
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;
}
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:
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");
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:
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:
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:
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:
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:
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:
#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:
* 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"
#ifdef HAVE_IEEE754_H
#include <ieee754.h> /* 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
#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 )
{
/* 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;
}
PushTaggedDouble(e); \
}
-#ifdef PROVIDE_WORD
#define OP_WW_B(e) \
{ \
StgWord x = PopTaggedWord(); \
StgWord x = PopTaggedWord(); \
PushTaggedWord(e); \
}
-#endif
-#ifdef PROVIDE_ADDR
#define OP_AA_B(e) \
{ \
StgAddr x = PopTaggedAddr(); \
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(); \
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(); \
s; \
}
-#endif /* PROVIDE_ADDR */
#define OP_FF_B(e) \
{ \
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) \
{ \
} \
}
-#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" );
}
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;
}
-/* 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(x<y); break;
- case i_leChar: OP_CC_B(x<=y); break;
- case i_charToInt: OP_C_I(x); break;
- case i_intToChar: OP_I_C(x); break;
-
- case i_gtInt: OP_II_B(x>y); 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;
- case i_leInt: OP_II_B(x<=y); break;
- case i_minInt: OP__I(INT_MIN); break;
- case i_maxInt: OP__I(INT_MAX); break;
- case i_plusInt: OP_II_I(x+y); break;
- case i_minusInt: OP_II_I(x-y); break;
- case i_timesInt: OP_II_I(x*y); break;
- case i_quotInt:
- {
- int x = PopTaggedInt();
- int y = PopTaggedInt();
- if (y == 0) {
- obj = raiseDiv0("quotInt");
- goto enterLoop;
- }
- /* ToDo: protect against minInt / -1 errors
- * (repeat for all other division primops)
- */
- PushTaggedInt(x/y);
- }
- break;
- case i_remInt:
- {
- int x = PopTaggedInt();
- int y = PopTaggedInt();
- if (y == 0) {
- obj = raiseDiv0("remInt");
- goto enterLoop;
- }
- PushTaggedInt(x%y);
- }
- break;
- case i_quotRemInt:
- {
- StgInt x = PopTaggedInt();
- StgInt y = PopTaggedInt();
- if (y == 0) {
- obj = raiseDiv0("quotRemInt");
- goto enterLoop;
- }
- PushTaggedInt(x%y); /* last result */
- PushTaggedInt(x/y); /* first result */
- }
- break;
- case i_negateInt: OP_I_I(-x); break;
-
- case i_andInt: OP_II_I(x&y); break;
- case i_orInt: OP_II_I(x|y); break;
- case i_xorInt: OP_II_I(x^y); break;
- case i_notInt: OP_I_I(~x); break;
- case i_shiftLInt: OP_II_I(x<<y); break;
- case i_shiftRAInt: OP_II_I(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(x<y); break;
- case i_leInt64: OP_zz_B(x<=y); break;
- case i_minInt64: OP__z(0x800000000000LL); break;
- case i_maxInt64: OP__z(0x7fffffffffffLL); break;
- case i_plusInt64: OP_zz_z(x+y); break;
- case i_minusInt64: OP_zz_z(x-y); break;
- case i_timesInt64: OP_zz_z(x*y); break;
- case i_quotInt64:
- {
- StgInt64 x = PopTaggedInt64();
- StgInt64 y = PopTaggedInt64();
- if (y == 0) {
- obj = raiseDiv0("quotInt64");
- goto enterLoop;
- }
- /* ToDo: protect against minInt64 / -1 errors
- * (repeat for all other division primops)
+ 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(x<y); break;
+ case i_leChar: OP_CC_B(x<=y); break;
+ case i_charToInt: OP_C_I(x); break;
+ case i_intToChar: OP_I_C(x); break;
+
+ case i_gtInt: OP_II_B(x>y); 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;
+ case i_leInt: OP_II_B(x<=y); break;
+ case i_minInt: OP__I(INT_MIN); break;
+ case i_maxInt: OP__I(INT_MAX); break;
+ case i_plusInt: OP_II_I(x+y); break;
+ case i_minusInt: OP_II_I(x-y); break;
+ case i_timesInt: OP_II_I(x*y); break;
+ case i_quotInt:
+ {
+ int x = PopTaggedInt();
+ int y = PopTaggedInt();
+ if (y == 0) {
+ return (raiseDiv0("quotInt"));
+ }
+ /* ToDo: protect against minInt / -1 errors
+ * (repeat for all other division primops)
*/
- PushTaggedInt64(x/y);
- }
- break;
- case i_remInt64:
- {
- StgInt64 x = PopTaggedInt64();
- StgInt64 y = PopTaggedInt64();
- if (y == 0) {
- obj = raiseDiv0("remInt64");
- goto enterLoop;
- }
- PushTaggedInt64(x%y);
- }
- break;
- case i_quotRemInt64:
- {
- StgInt64 x = PopTaggedInt64();
- StgInt64 y = PopTaggedInt64();
- if (y == 0) {
- obj = raiseDiv0("quotRemInt64");
- goto enterLoop;
- }
- PushTaggedInt64(x%y); /* last result */
- PushTaggedInt64(x/y); /* first result */
- }
- break;
- case i_negateInt64: OP_z_z(-x); break;
-
- case i_andInt64: OP_zz_z(x&y); break;
- case i_orInt64: OP_zz_z(x|y); break;
- case i_xorInt64: OP_zz_z(x^y); break;
- case i_notInt64: OP_z_z(~x); break;
- case i_shiftLInt64: OP_zW_z(x<<y); break;
- case i_shiftRAInt64: OP_zW_z(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;
- case i_leWord: OP_WW_B(x<=y); break;
- case i_minWord: OP__W(0); break;
- case i_maxWord: OP__W(UINT_MAX); break;
- case i_plusWord: OP_WW_W(x+y); break;
- case i_minusWord: OP_WW_W(x-y); break;
- case i_timesWord: OP_WW_W(x*y); break;
- case i_quotWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- obj = raiseDiv0("quotWord");
- goto enterLoop;
- }
- PushTaggedWord(x/y);
- }
- break;
- case i_remWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- obj = raiseDiv0("remWord");
- goto enterLoop;
- }
- PushTaggedWord(x%y);
- }
- break;
- case i_quotRemWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- obj = raiseDiv0("quotRemWord");
- goto enterLoop;
- }
- PushTaggedWord(x%y); /* last result */
- PushTaggedWord(x/y); /* first result */
- }
- break;
- case i_negateWord: OP_W_W(-x); break;
- case i_andWord: OP_WW_W(x&y); break;
- case i_orWord: OP_WW_W(x|y); break;
- case i_xorWord: OP_WW_W(x^y); break;
- case i_notWord: OP_W_W(~x); break;
- case i_shiftLWord: OP_WW_W(x<<y); break;
- case i_shiftRAWord: OP_WW_W(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;
- case i_leAddr: OP_AA_B(x<=y); break;
- case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
- case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
-
- case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
- case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
- case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
+ PushTaggedInt(x/y);
+ }
+ break;
+ case i_remInt:
+ {
+ int x = PopTaggedInt();
+ int y = PopTaggedInt();
+ if (y == 0) {
+ return (raiseDiv0("remInt"));
+ }
+ PushTaggedInt(x%y);
+ }
+ break;
+ case i_quotRemInt:
+ {
+ StgInt x = PopTaggedInt();
+ StgInt y = PopTaggedInt();
+ if (y == 0) {
+ return (raiseDiv0("quotRemInt"));
+ }
+ PushTaggedInt(x%y); /* last result */
+ PushTaggedInt(x/y); /* first result */
+ }
+ break;
+ case i_negateInt: OP_I_I(-x); break;
+
+ case i_andInt: OP_II_I(x&y); break;
+ case i_orInt: OP_II_I(x|y); break;
+ case i_xorInt: OP_II_I(x^y); break;
+ case i_notInt: OP_I_I(~x); break;
+ case i_shiftLInt: OP_II_I(x<<y); break;
+ case i_shiftRAInt: OP_II_I(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;
+ case i_leWord: OP_WW_B(x<=y); break;
+ case i_minWord: OP__W(0); break;
+ case i_maxWord: OP__W(UINT_MAX); break;
+ case i_plusWord: OP_WW_W(x+y); break;
+ case i_minusWord: OP_WW_W(x-y); break;
+ case i_timesWord: OP_WW_W(x*y); break;
+ case i_quotWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ return (raiseDiv0("quotWord"));
+ }
+ PushTaggedWord(x/y);
+ }
+ break;
+ case i_remWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ return (raiseDiv0("remWord"));
+ }
+ PushTaggedWord(x%y);
+ }
+ break;
+ case i_quotRemWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ return (raiseDiv0("quotRemWord"));
+ }
+ PushTaggedWord(x%y); /* last result */
+ PushTaggedWord(x/y); /* first result */
+ }
+ break;
+ case i_negateWord: OP_W_W(-x); break;
+ case i_andWord: OP_WW_W(x&y); break;
+ case i_orWord: OP_WW_W(x|y); break;
+ case i_xorWord: OP_WW_W(x^y); break;
+ case i_notWord: OP_W_W(~x); break;
+ case i_shiftLWord: OP_WW_W(x<<y); break;
+ case i_shiftRAWord: OP_WW_W(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(x<y); break;
+ case i_leAddr: OP_AA_B(x<=y); break;
+ case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
+ case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
+
+ case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
+ case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
+ case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
- case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
- case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
- case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
-#ifdef PROVIDE_INT64
- case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrzh(r,x,y)); break;
- case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrzh(r,x,y)); break;
- case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrzh(x,y,z)); break;
-#endif
+ case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
+ case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
+ case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
- case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
- case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
- case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
+ case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
+ case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
+ case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
- case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
- case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
- case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
+ case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
+ case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
+ case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
- case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
- case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
- case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
+ case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
+ case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
+ case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
#ifdef PROVIDE_STABLE
- case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
- case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
- case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
+ case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
+ case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
+ case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
#endif
-#endif /* PROVIDE_ADDR */
-
-#ifdef PROVIDE_INTEGER
- case i_compareInteger:
- {
- mpz_ptr x = PopTaggedInteger();
- mpz_ptr y = PopTaggedInteger();
- StgInt r = mpz_cmp(x,y);
- PushTaggedInt(r<0 ? -1 : (r>0 ? 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(x<y); break;
- case i_leFloat: OP_FF_B(x<=y); break;
- case i_minFloat: OP__F(FLT_MIN); break;
- case i_maxFloat: OP__F(FLT_MAX); break;
- case i_radixFloat: OP__I(FLT_RADIX); break;
- case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
- case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
- case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
- case i_plusFloat: OP_FF_F(x+y); break;
- case i_minusFloat: OP_FF_F(x-y); break;
- case i_timesFloat: OP_FF_F(x*y); break;
- case i_divideFloat:
- {
- StgFloat x = PopTaggedFloat();
- StgFloat y = PopTaggedFloat();
+#ifdef STANDALONE_INTEGER
+ case i_compareInteger:
+ {
+ B* x = IntegerInsideByteArray(PopPtr());
+ B* y = IntegerInsideByteArray(PopPtr());
+ StgInt r = do_cmp(x,y);
+ PushTaggedInt(r<0 ? -1 : (r>0 ? 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<y); break;
+ case i_leFloat: OP_FF_B(x<=y); break;
+ case i_minFloat: OP__F(FLT_MIN); break;
+ case i_maxFloat: OP__F(FLT_MAX); break;
+ case i_radixFloat: OP__I(FLT_RADIX); break;
+ case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
+ case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
+ case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
+ case i_plusFloat: OP_FF_F(x+y); break;
+ case i_minusFloat: OP_FF_F(x-y); break;
+ case i_timesFloat: OP_FF_F(x*y); break;
+ case i_divideFloat:
+ {
+ StgFloat x = PopTaggedFloat();
+ StgFloat y = PopTaggedFloat();
#if 0
- if (y == 0) {
- obj = raiseDiv0("divideFloat");
- goto enterLoop;
- }
-#endif
- PushTaggedFloat(x/y);
- }
- break;
- case i_negateFloat: OP_F_F(-x); break;
- case i_floatToInt: OP_F_I(x); break;
- case i_intToFloat: OP_I_F(x); break;
- case i_expFloat: OP_F_F(exp(x)); break;
- case i_logFloat: OP_F_F(log(x)); break;
- case i_sqrtFloat: OP_F_F(sqrt(x)); break;
- case i_sinFloat: OP_F_F(sin(x)); break;
- case i_cosFloat: OP_F_F(cos(x)); break;
- case i_tanFloat: OP_F_F(tan(x)); break;
- case i_asinFloat: OP_F_F(asin(x)); break;
- case i_acosFloat: OP_F_F(acos(x)); break;
- case i_atanFloat: OP_F_F(atan(x)); break;
- case i_sinhFloat: OP_F_F(sinh(x)); break;
- case i_coshFloat: OP_F_F(cosh(x)); break;
- case i_tanhFloat: OP_F_F(tanh(x)); break;
- case i_powerFloat: OP_FF_F(pow(x,y)); break;
-
-#ifdef PROVIDE_INT64
- /* Based on old Hugs code */
- /* ToDo: use ~/fptools/ghc/runtime/prims/PrimArith.lc */
- case i_encodeFloatz: OP_zI_F(ldexp(x,y)); break;
- case i_decodeFloatz:
- {
- /* ToDo: this code is known to give very approximate results
- * (even when StgInt64 overflow doesn't occur)
- */
- double f0 = PopTaggedFloat();
- int n;
- double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
- double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
- PushTaggedInt(n-FLT_MANT_DIG);
- PushTaggedInt64((StgInt64)f2);
-#if 1 /* paranoia */
- if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
- fprintf(stderr,"*** primDecodeFloat mismatch: %.10f != %.10f\n",
- ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
- }
-#endif
- }
- break;
-#endif /* PROVIDE_INT64 */
-#ifdef PROVIDE_INTEGER
- case i_encodeFloatZ: OP_ZI_F(__encodeFloat(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(x<y); break;
- case i_leDouble: OP_DD_B(x<=y) break;
- case i_minDouble: OP__D(DBL_MIN); break;
- case i_maxDouble: OP__D(DBL_MAX); break;
- case i_radixDouble: OP__I(FLT_RADIX); break;
- case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
- case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
- case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
- case i_plusDouble: OP_DD_D(x+y); break;
- case i_minusDouble: OP_DD_D(x-y); break;
- case i_timesDouble: OP_DD_D(x*y); break;
- case i_divideDouble:
- {
- StgDouble x = PopTaggedDouble();
- StgDouble y = PopTaggedDouble();
+ PushTaggedFloat(x/y);
+ }
+ break;
+ case i_negateFloat: OP_F_F(-x); break;
+ case i_floatToInt: OP_F_I(x); break;
+ case i_intToFloat: OP_I_F(x); break;
+ case i_expFloat: OP_F_F(exp(x)); break;
+ case i_logFloat: OP_F_F(log(x)); break;
+ case i_sqrtFloat: OP_F_F(sqrt(x)); break;
+ case i_sinFloat: OP_F_F(sin(x)); break;
+ case i_cosFloat: OP_F_F(cos(x)); break;
+ case i_tanFloat: OP_F_F(tan(x)); break;
+ case i_asinFloat: OP_F_F(asin(x)); break;
+ case i_acosFloat: OP_F_F(acos(x)); break;
+ case i_atanFloat: OP_F_F(atan(x)); break;
+ case i_sinhFloat: OP_F_F(sinh(x)); break;
+ case i_coshFloat: OP_F_F(cosh(x)); break;
+ case i_tanhFloat: OP_F_F(tanh(x)); break;
+ case i_powerFloat: OP_FF_F(pow(x,y)); break;
+
+#ifdef STANDALONE_INTEGER
+ case i_encodeFloatZ:
+ {
+ StgPtr sig = PopPtr();
+ StgInt exp = PopTaggedInt();
+ PushTaggedFloat(
+ B__encodeFloat(IntegerInsideByteArray(sig), exp)
+ );
+ }
+ break;
+ case i_decodeFloatZ:
+ {
+ StgFloat f = PopTaggedFloat();
+ StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
+ StgInt exp;
+ B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
+ PushTaggedInt(exp);
+ PushPtr(sig);
+ }
+ break;
+#else
+#error encode/decodeFloatZ not yet implemented for GHC ints
+#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(x<y); break;
+ case i_leDouble: OP_DD_B(x<=y) break;
+ case i_minDouble: OP__D(DBL_MIN); break;
+ case i_maxDouble: OP__D(DBL_MAX); break;
+ case i_radixDouble: OP__I(FLT_RADIX); break;
+ case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
+ case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
+ case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
+ case i_plusDouble: OP_DD_D(x+y); break;
+ case i_minusDouble: OP_DD_D(x-y); break;
+ case i_timesDouble: OP_DD_D(x*y); break;
+ case i_divideDouble:
+ {
+ StgDouble x = PopTaggedDouble();
+ StgDouble y = PopTaggedDouble();
#if 0
- if (y == 0) {
- obj = raiseDiv0("divideDouble");
- goto enterLoop;
- }
+ if (y == 0) {
+ return (raiseDiv0("divideDouble"));
+ }
#endif
- PushTaggedDouble(x/y);
- }
- break;
- case i_negateDouble: OP_D_D(-x); break;
- case i_doubleToInt: OP_D_I(x); break;
- case i_intToDouble: OP_I_D(x); break;
- case i_doubleToFloat: OP_D_F(x); break;
- case i_floatToDouble: OP_F_F(x); break;
- case i_expDouble: OP_D_D(exp(x)); break;
- case i_logDouble: OP_D_D(log(x)); break;
- case i_sqrtDouble: OP_D_D(sqrt(x)); break;
- case i_sinDouble: OP_D_D(sin(x)); break;
- case i_cosDouble: OP_D_D(cos(x)); break;
- case i_tanDouble: OP_D_D(tan(x)); break;
- case i_asinDouble: OP_D_D(asin(x)); break;
- case i_acosDouble: OP_D_D(acos(x)); break;
- case i_atanDouble: OP_D_D(atan(x)); break;
- case i_sinhDouble: OP_D_D(sinh(x)); break;
- case i_coshDouble: OP_D_D(cosh(x)); break;
- case i_tanhDouble: OP_D_D(tanh(x)); break;
- case i_powerDouble: OP_DD_D(pow(x,y)); break;
-#ifdef PROVIDE_INT64
- case i_encodeDoublez: OP_zI_D(ldexp(x,y)); break;
- case i_decodeDoublez:
- {
- /* ToDo: this code is known to give very approximate results
- * (even when StgInt64 overflow doesn't occur)
- */
- double f0 = PopTaggedDouble();
- int n;
- double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
- double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
- PushTaggedInt(n-FLT_MANT_DIG);
- PushTaggedInt64((StgInt64)f2);
-#if 1 /* paranoia */
- if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
- fprintf(stderr,"*** primDecodeDouble mismatch: %.10f != %.10f\n",
- ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
- }
+ PushTaggedDouble(x/y);
+ }
+ break;
+ case i_negateDouble: OP_D_D(-x); break;
+ case i_doubleToInt: OP_D_I(x); break;
+ case i_intToDouble: OP_I_D(x); break;
+ case i_doubleToFloat: OP_D_F(x); break;
+ case i_floatToDouble: OP_F_F(x); break;
+ case i_expDouble: OP_D_D(exp(x)); break;
+ case i_logDouble: OP_D_D(log(x)); break;
+ case i_sqrtDouble: OP_D_D(sqrt(x)); break;
+ case i_sinDouble: OP_D_D(sin(x)); break;
+ case i_cosDouble: OP_D_D(cos(x)); break;
+ case i_tanDouble: OP_D_D(tan(x)); break;
+ case i_asinDouble: OP_D_D(asin(x)); break;
+ case i_acosDouble: OP_D_D(acos(x)); break;
+ case i_atanDouble: OP_D_D(atan(x)); break;
+ case i_sinhDouble: OP_D_D(sinh(x)); break;
+ case i_coshDouble: OP_D_D(cosh(x)); break;
+ case i_tanhDouble: OP_D_D(tanh(x)); break;
+ case i_powerDouble: OP_DD_D(pow(x,y)); break;
+
+#ifdef STANDALONE_INTEGER
+ case i_encodeDoubleZ:
+ {
+ StgPtr sig = PopPtr();
+ StgInt exp = PopTaggedInt();
+ PushTaggedDouble(
+ B__encodeDouble(IntegerInsideByteArray(sig), exp)
+ );
+ }
+ break;
+ case i_decodeDoubleZ:
+ {
+ StgDouble d = PopTaggedDouble();
+ StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
+ StgInt exp;
+ B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
+ PushTaggedInt(exp);
+ PushPtr(sig);
+ }
+ break;
+#else
+#error encode/decodeDoubleZ not yet implemented for GHC ints
#endif
- }
- break;
-#endif /* PROVIDE_INT64 */
-#ifdef PROVIDE_INTEGER
- case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(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
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
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);
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;
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);
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));
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;
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);
#ifdef PROVIDE_FOREIGN
case FOREIGN_REP:
#endif
-#ifdef PROVIDE_ARRAY
case BARR_REP:
case MUTBARR_REP:
-#endif
sz += sizeof(StgPtr);
break;
default:
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 */
-/* -*- 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 $
*
* ------------------------------------------------------------------------*/
#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)
/* --------------------------------------------------------------------------
projects / ghc-hetmet.git / commitdiff