Commit b9ad54f9 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-04-27 10:06:47 by sewardj]

Changes to improve runtime performance of STG Hugs.
-- Reorganisation of the evaluator (Evaluator.c).
-- Changes to code emission (Assembler.c) to support peephole opts
-- An experimental simplifier (optimise.c).
-- Many supporting bug fixes and minor changes.
-- Experimental implementation of integer for standalone hugs (sainteger.c).
parent 2948d495
/* -----------------------------------------------------------------------------
* $Id: Assembler.h,v 1.5 1999/03/01 14:47:09 sewardj Exp $
* $Id: Assembler.h,v 1.6 1999/04/27 10:07:22 sewardj Exp $
*
* (c) The GHC Team 1994-1998.
*
......@@ -84,18 +84,9 @@ typedef enum {
/* The following can be passed to C */
CHAR_REP = 'C',
INT_REP = 'I',
#ifdef PROVIDE_INT64
INT64_REP = 'z',
#endif
#ifdef PROVIDE_INTEGER
INTEGER_REP = 'Z',
#endif
#ifdef PROVIDE_WORD
WORD_REP = 'W',
#endif
#ifdef PROVIDE_ADDR
ADDR_REP = 'A',
#endif
FLOAT_REP = 'F',
DOUBLE_REP = 'D',
#ifdef PROVIDE_STABLE
......@@ -107,10 +98,8 @@ typedef enum {
#ifdef PROVIDE_WEAK
WEAK_REP = 'w', /* Weak a */
#endif
#ifdef PROVIDE_ARRAY
BARR_REP = 'x', /* PrimByteArray a */
MUTBARR_REP = 'm', /* PrimMutableByteArray s a */
#endif
/* The following can't be passed to C */
PTR_REP = 'P',
......@@ -121,11 +110,9 @@ typedef enum {
IO_REP = 'i', /* IO a */
HANDLER_REP = 'H', /* Exception -> IO a */
ERROR_REP = 'E', /* Exception */
#ifdef PROVIDE_ARRAY
ARR_REP = 'X', /* PrimArray a */
REF_REP = 'R', /* Ref s a */
MUTARR_REP = 'M', /* PrimMutableArray s a */
#endif
#ifdef PROVIDE_CONCURRENT
THREADID_REP = 'T', /* ThreadId */
MVAR_REP = 'r', /* MVar a */
......@@ -164,6 +151,8 @@ extern int asmObjectHasClosure( AsmObject obj );
extern AsmClosure asmClosureOfObject ( AsmObject obj );
extern void asmMarkObject ( AsmObject obj );
extern int asmRepSizeW ( AsmRep rep );
/* --------------------------------------------------------------------------
* Generating instruction streams
* ------------------------------------------------------------------------*/
......@@ -194,21 +183,12 @@ extern void asmReturnUnboxed ( AsmBCO bco, AsmRep rep );
/* push unboxed Ints, Floats, etc */
extern void asmConstInt ( AsmBCO bco, AsmInt x );
#ifdef PROVIDE_ADDR
extern void asmConstAddr ( AsmBCO bco, AsmAddr x );
#endif
#ifdef PROVIDE_WORD
extern void asmConstWord ( AsmBCO bco, AsmWord x );
#endif
extern void asmConstChar ( AsmBCO bco, AsmChar x );
extern void asmConstFloat ( AsmBCO bco, AsmFloat x );
extern void asmConstDouble ( AsmBCO bco, AsmDouble x );
#ifdef PROVIDE_INT64
extern void asmConstInt64 ( AsmBCO bco, AsmInt64 x );
#endif
#ifdef PROVIDE_INTEGER
extern void asmConstInteger ( AsmBCO bco, AsmString x );
#endif
/* Which monad (if any) does the primop live in? */
typedef enum {
......
......@@ -13,8 +13,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: options.h,v $
* $Revision: 1.4 $
* $Date: 1999/03/01 14:47:09 $
* $Revision: 1.5 $
* $Date: 1999/04/27 10:07:22 $
* ------------------------------------------------------------------------*/
......@@ -34,7 +34,7 @@
* for HUGSFLAGS in the registry (Win32 only). In all cases, use a
* string of the form -P"...".
*/
#define HUGSPATH ""
#define HUGSPATH "."
/* The directory name which is substituted for the string "{Hugs}"
* in a path variable. This normally points to where the Hugs libraries
......@@ -104,7 +104,7 @@
#define LARGE_HUGS 1
#define NUM_SYNTAX 100
#define NUM_TUPLES /*100*/ 10
#define NUM_TUPLES /*100*/ 20
#define NUM_OFFSETS 1024
#define NUM_CHARS 256
#if TREX
......@@ -124,7 +124,7 @@
#define MINIMUMHEAP Pick(7500, 19000, 19000)
#define MAXIMUMHEAP Pick(32765, 0, 0)
#define DEFAULTHEAP Pick(28000, 50000, 1500000 /*300000*/ )
#define DEFAULTHEAP Pick(28000, 50000, 650000)
#define NUM_SCRIPTS Pick(64, 100, 100)
#define NUM_MODULE NUM_SCRIPTS
......@@ -173,58 +173,40 @@
/* Should quantifiers be displayed in error messages.
* Warning: not consistently used.
*/
#define DISPLAY_QUANTIFIERS 1
#define DISPLAY_QUANTIFIERS 0
/* Flags to determine which raw representations and operations are available
* Notes:
* o the INTEGER implementation is quite different from GHC's
* implementation so you usually don't PROVIDE_INTEGER if
* using GHC compiled code.
* o if you turn everything on, you might end up with more then 256
* bytecodes: check the value of i_ccall (the lst bytecode) to check
* o Addrs are used to represent literal Strings in Hugs - so you can't
* really turn them off.
* o Either Int64 or Integer has to be provided so that we can
* define BIGNUMTYPE (below)
* (JRS), 22apr99: I don't think any of the #undef'd ones will work
* without attention. However, standard Haskell 98 is supported
* is supported without needing them.
*/
#define PROVIDE_INTEGER
#undef PROVIDE_INT64
#undef PROVIDE_WORD
#define PROVIDE_ADDR
#undef PROVIDE_STABLE
#define PROVIDE_FOREIGN
#undef PROVIDE_FOREIGN
#undef PROVIDE_WEAK
#define PROVIDE_ARRAY
#undef PROVIDE_CONCURRENT
#undef PROVIDE_PTREQUALITY
#undef PROVIDE_COERCE
/* The following aren't options at the moment - but could be
* #define PROVIDE_FLOAT
* #define PROVIDE_DOUBLE
*/
/* Flags to determine how Haskell types are mapped onto internal types.
* Note that this has to be an injection: you can't have two names
* for the same internal type.
* Also, the settings have to be consistent with GHC if GHC is being used.
*/
/* Set to 1 to use a non-GMP implementation of integer, in the
standalone Hugs. Set to 0 in the combined GHC-Hugs system,
in which case GNU MP will be used.
*/
#define STANDALONE_INTEGER 1
#define BIGNUM_IS_INTEGER 1
#define BIGNUM_IS_INT64 0
/* Enable a crude profiler which counts BCO entries, bytes allocated
and bytecode insns executed on a per-fn basis. Used for assessing
the effect of the simplifier/optimiser.
*/
#undef CRUDE_PROFILING
#if BIGNUM_IS_INT64
#define BIGNUMTYPE Int64
#elif BIGNUM_IS_INTEGER
#define BIGNUMTYPE Integer
#else
#warning BIGNUMTYPE undefined
#endif
/* Is the default default (Int,Double) or (Integer,Double)?
*/
#define DEFAULT_BIGNUM 0
#define DEFAULT_BIGNUM 1
/* Should lambda lifter lift constant expressions out to top level?
* Experimental optimisation.
......@@ -234,7 +216,7 @@
/* Should we run optimizer on Hugs code?
* Experimental optimisation.
*/
#define USE_HUGS_OPTIMIZER 0
#define USE_HUGS_OPTIMIZER 1
/* Are things being used in an interactive setting or a batch setting?
* In an interactive setting, System.exitWith should not call _exit
......@@ -324,15 +306,6 @@
* these flags.
* ------------------------------------------------------------------------*/
/* Define if you want to be able to derive instances of each class. */
#define DERIVE_EQ 1
#define DERIVE_ORD 1
#define DERIVE_ENUM 1
#define DERIVE_IX 1
#define DERIVE_SHOW 1
#define DERIVE_READ 1
#define DERIVE_BOUNDED 1
/* Define if single-element dictionaries are implemented by newtype.
* Should be turned on. Mostly used to make it easier to find which
* bits of code implement this optimisation and as a way of documenting
......@@ -351,9 +324,6 @@
* or "fromFloat" */
#define OVERLOADED_CONSTANTS 1
/* turn this off to remove the ultramagical treatment of the Eval class */
#define EVAL_INSTANCES 0
/* Define to include support for (n+k) patterns.
* Warning: many people in the Haskell committee want to remove n+k patterns.
*/
......
# ----------------------------------------------------------------------------- #
# $Id: Makefile,v 1.6 1999/03/09 14:51:03 sewardj Exp $ #
# $Id: Makefile,v 1.7 1999/04/27 10:06:47 sewardj Exp $ #
# ----------------------------------------------------------------------------- #
TOP = ../..
......@@ -24,30 +24,25 @@ HS_SRCS =
Y_SRCS = parser.y
C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \
translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \
hugs.c dynamic.c stg.c
hugs.c dynamic.c stg.c sainteger.c
SRC_CC_OPTS = -O2 -Winline -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wstrict-prototypes
SRC_CC_OPTS = -O2 -g -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused
GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/gmp/libgmp.a
GHC_DYN_CBITS_DIR = $(TOP)/ghc/lib/std/cbits
GHC_DYN_CBITS = $(GHC_DYN_CBITS_DIR)/libHS_cbits.so
GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a
all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs
all :: parser.c $(GHC_LIBS_NEEDED) nHandle.so hugs
### EXTREMELY hacky
hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o ../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o \
../rts/Printer.o
$(CC) -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm
hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o \
../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o ../rts/Printer.o \
nHandle.so
$(CC) -o $@ -rdynamic $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm
$(GHC_DYN_CBITS):
### (cd $(GHC_DYN_CBITS_DIR); make EXTRA_CC_OPTS="-fpic -optc-g" ; gcc -shared -o libHS_cbits.so *.o)
(cd $(GHC_DYN_CBITS_DIR); rm -f *.o ; gcc -I../../../includes -fPIC -g -Wall -c *.c ; gcc -shared -o libHS_cbits.so *.o)
cp -f $(GHC_DYN_CBITS) .
nHandle.so:
gcc -O -fPIC -shared -o nHandle.so nHandle.c
$(TOP)/ghc/rts/libHSrts.a:
(cd $(TOP)/ghc/rts ; make clean ; make)
$(TOP)/ghc/rts/gmp/libgmp.a:
(cd $(TOP)/ghc/rts/gmp ; make clean ; make)
cleanish:
/bin/rm *.o
......@@ -56,10 +51,10 @@ snapshot:
/bin/rm -f snapshot.tar
tar cvf snapshot.tar Makefile *.[chy] *-ORIG-* \
../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \
../rts/ForeignCall.c ../rts/Printer.c \
../rts/ForeignCall.c ../rts/Printer.c ../rts/QueueTemplate.h \
../includes/options.h ../includes/Assembler.h nHandle.c \
../includes/Assembler.h ../rts/Bytecodes.h \
lib/*.hs
lib/*.hs runnofib runallnofib
# --------------------------------------------------------------------- #
......@@ -82,9 +77,8 @@ checkrun: all
# Cleanery & misc #
# --------------------------------------------------------------------- #
CLEAN_FILES += hugs libHS_cbits.so $(GHC_DYN_CBITS) $(GHC_DYN_CBITS_DIR)/*.o
CLEAN_FILES += hugs nHandle.so
CLEAN_FILES += $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/*.o
CLEAN_FILES += $(TOP)/ghc/rts/gmp/libgmp.a $(TOP)/ghc/rts/gmp/*.o $(TOP)/ghc/rts/gmp/*/*.o
CLEAN_FILES += parser.c
INSTALL_LIBEXECS = hugs
......
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: backend.h,v $
* $Revision: 1.3 $
* $Date: 1999/03/09 14:51:04 $
* $Revision: 1.4 $
* $Date: 1999/04/27 10:06:47 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -38,10 +38,10 @@
* | Name -- let-bound (effectively)
* -- always unboxed (PTR_REP)
*
* Alt -> (Pat,Expr)
* Pat -> Var -- bound to a constructor, a tuple or unbound
* PrimAlt -> ([PrimPat],Expr)
* PrimPat -> Var -- bound to int or unbound
* Alt -> DEEFALT (Var,Expr) -- var bound to NIL
* | CASEALT (Con,[Var],Expr) -- vars bound to NIL;
* -- Con is Name or TUPLE
* PrimAlt -> PRIMALT ([Var],Expr) -- vars bound to NIL or int
*
* We use pointer equality to distinguish variables.
* The info field of a Var is used as follows in various phases:
......@@ -50,66 +50,64 @@
* Freevar analysis: list of free vars after
* Lambda lifting: freevar list or UNIT on input, discarded after
* Code generation: unused
* Optimisation: number of uses (sort-of) of let-bound variable
* ------------------------------------------------------------------------*/
typedef Cell StgRhs;
typedef Cell StgExpr;
typedef Cell StgAtom;
typedef Cell StgVar; /* Could be a Name or an STGVAR */
typedef Pair StgCaseAlt;
typedef StgVar StgPat;
typedef Cell StgCaseAlt;
typedef Cell StgPrimAlt;
typedef Cell StgDiscr;
typedef Pair StgPrimAlt;
typedef StgVar StgPrimPat;
typedef Cell StgRep; /* PTR_REP | .. DOUBLE_REP */
#define mkStgLet(binds,body) ap(LETREC,pair(binds,body))
#define stgLetBinds(e) fst(snd(e))
#define stgLetBody(e) snd(snd(e))
#define mkStgLet(binds,body) ap(LETREC,pair(binds,body))
#define stgLetBinds(e) fst(snd(e))
#define stgLetBody(e) snd(snd(e))
#define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info))
#define stgVarBody(e) fst3(snd(e))
#define stgVarRep(e) snd3(snd(e))
#define stgVarInfo(e) thd3(snd(e))
#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts))
#define stgCaseScrut(e) fst(snd(e))
#define stgCaseAlts(e) snd(snd(e))
#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts))
#define stgCaseScrut(e) fst(snd(e))
#define stgCaseAlts(e) snd(snd(e))
#define mkStgCaseAlt(discr,vs,e) pair(mkStgVar(mkStgCon(discr,vs),NIL),e)
#define stgCaseAltPat(alt) fst(alt)
#define stgCaseAltBody(alt) snd(alt)
#define mkStgCaseAlt(con,vs,e) ap(CASEALT,triple(con,vs,e))
#define stgCaseAltCon(alt) fst3(snd(alt))
#define stgCaseAltVars(alt) snd3(snd(alt))
#define stgCaseAltBody(alt) thd3(snd(alt))
#define stgPatDiscr(pat) stgConCon(stgVarBody(pat))
#define stgPatVars(pat) stgConArgs(stgVarBody(pat))
#define mkStgDefault(v,e) ap(DEEFALT,pair(v,e))
#define stgDefaultVar(alt) fst(snd(alt))
#define stgDefaultBody(alt) snd(snd(alt))
#define isDefaultAlt(alt) (fst(alt)==DEEFALT)
#define isDefaultPat(pat) (isNull(stgVarBody(pat)))
#define isStgDefault(alt) (isDefaultPat(stgCaseAltPat(alt)))
#define mkStgDefault(v,e) pair(v,e)
#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts))
#define stgPrimCaseScrut(e) fst(snd(e))
#define stgPrimCaseAlts(e) snd(snd(e))
#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts))
#define stgPrimCaseScrut(e) fst(snd(e))
#define stgPrimCaseAlts(e) snd(snd(e))
#define mkStgPrimAlt(vs,body) ap(PRIMALT,pair(vs,body))
#define stgPrimAltVars(alt) fst(snd(alt))
#define stgPrimAltBody(alt) snd(snd(alt))
#define mkStgPrimAlt(vs,body) pair(vs,body)
#define stgPrimAltPats(alt) fst(alt)
#define stgPrimAltBody(alt) snd(alt)
#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args))
#define stgAppFun(e) fst(snd(e))
#define stgAppArgs(e) snd(snd(e))
#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args))
#define stgAppFun(e) fst(snd(e))
#define stgAppArgs(e) snd(snd(e))
#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args))
#define stgPrimOp(e) fst(snd(e))
#define stgPrimArgs(e) snd(snd(e))
#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args))
#define stgPrimOp(e) fst(snd(e))
#define stgPrimArgs(e) snd(snd(e))
#define mkStgCon(con,args) ap(STGCON,pair(con,args))
#define stgConCon(e) fst(snd(e))
#define stgConArgs(e) snd(snd(e))
#define mkStgCon(con,args) ap(STGCON,pair(con,args))
#define stgConCon(e) fst(snd(e))
#define stgConArgs(e) snd(snd(e))
#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body))
#define stgLambdaArgs(e) fst(snd(e))
#define stgLambdaBody(e) snd(snd(e))
#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body))
#define stgLambdaArgs(e) fst(snd(e))
#define stgLambdaBody(e) snd(snd(e))
extern int stgConTag ( StgDiscr d );
extern void* stgConInfo ( StgDiscr d );
......@@ -126,9 +124,10 @@ extern StgExpr makeStgLet ( List binds, StgExpr body );
extern StgExpr makeStgIf ( StgExpr cond, StgExpr e1, StgExpr e2 );
extern Bool isStgVar ( StgRhs rhs );
extern Bool isAtomic ( StgRhs rhs );
extern StgVar mkStgVar ( StgRhs rhs, Cell info );
extern Int stgSize ( StgExpr e );
#define mkStgRep(c) mkChar(c)
/*-------------------------------------------------------------------------*/
......@@ -179,7 +178,16 @@ extern Void ppStgVars ( List vs );
extern List liftBinds( List binds );
extern Void liftControl ( Int what );
extern StgExpr substExpr ( List sub, StgExpr e );
extern StgExpr substExpr ( List sub, StgExpr e );
extern StgExpr zubstExpr ( List sub, StgExpr e );
extern List freeVarsBind Args((List, StgVar));
extern Void optimiseBind Args((StgVar));
#ifdef CRUDE_PROFILING
extern void cp_init ( void );
extern void cp_enter ( Cell /*StgVar*/ );
extern void cp_bill_words ( int );
extern void cp_bill_insns ( int );
extern void cp_show ( void );
#endif
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
* $Revision: 1.5 $
* $Date: 1999/03/09 14:51:04 $
* $Revision: 1.6 $
* $Date: 1999/04/27 10:06:48 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -48,6 +48,8 @@ static AsmBCO cgRhs ( StgRhs rhs );
static void beginTop ( StgVar v );
static void endTop ( StgVar v );
static StgVar currentTop;
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
......@@ -105,11 +107,7 @@ static void cgBind( AsmBCO bco, StgVar v )
static Void pushVar( AsmBCO bco, StgVar v )
{
Cell info = stgVarInfo(v);
// if (!isStgVar(v)) {
//printf("\n\nprefail\n");
//print(v,1000);
assert(isStgVar(v));
//}
assert(isStgVar(v));
if (isPtr(info)) {
asmClosure(bco,ptrOf(info));
} else if (isInt(info)) {
......@@ -134,17 +132,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
case INTCELL:
asmConstInt(bco,intOf(e));
break;
#if BIGNUM_IS_INTEGER
case BIGCELL:
asmConstInteger(bco,bignumToString(e));
break;
#elif BIGNUM_IS_INT64
case BIGCELL:
asmConstInt64(bco,bignumOf(e));
break;
#else
#warning What is BIGNUM?
#endif
case FLOATCELL:
#if 0
asmConstFloat(bco,e); /* ToDo: support both float and double! */
......@@ -175,24 +165,26 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
{
AsmBCO bco = asmBeginContinuation(sp,alts);
#ifdef CRUDE_PROFILING
AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
#else
AsmBCO bco = asmBeginContinuation(sp, alts);
#endif
/* ppStgAlts(alts); */
for(; nonNull(alts); alts=tl(alts)) {
StgCaseAlt alt = hd(alts);
StgPat pat = stgCaseAltPat(alt);
StgExpr body = stgCaseAltBody(alt);
if (isDefaultPat(pat)) {
//AsmSp begin = asmBeginAlt(bco);
cgBind(bco,pat);
cgExpr(bco,root,body);
if (isDefaultAlt(alt)) {
cgBind(bco,stgDefaultVar(alt));
cgExpr(bco,root,stgDefaultBody(alt));
asmEndContinuation(bco);
return bco; /* ignore any further alternatives */
} else {
StgDiscr con = stgPatDiscr(pat);
List vs = stgPatVars(pat);
StgDiscr con = stgCaseAltCon(alt);
List vs = stgCaseAltVars(alt);
AsmSp begin = asmBeginAlt(bco);
AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
cgBind(bco,pat);
AsmPc fix = asmTest(bco,stgDiscrTag(con));
/* ToDo: omit in single constructor types! */
asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
if (isBoxingCon(con)) {
setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
} else {
......@@ -200,7 +192,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
map1Proc(cgBind,bco,reverse(vs));
asmEndUnpack(bco);
}
cgExpr(bco,root,body);
cgExpr(bco,root,stgCaseAltBody(alt));
asmEndAlt(bco,begin);
asmFixBranch(bco,fix);
}
......@@ -216,7 +208,7 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
if (isNull(pats)) {
cgExpr(bco,root,e);
} else {
StgPrimPat pat = hd(pats);
StgVar pat = hd(pats);
if (isInt(stgVarBody(pat))) {
/* asmTestInt leaves stack unchanged - so no need to adjust it */
AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
......@@ -310,7 +302,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
for(; nonNull(alts); alts=tl(alts)) {
StgPrimAlt alt = hd(alts);
List pats = stgPrimAltPats(alt);
List pats = stgPrimAltVars(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
map1Proc(cgBind,bco,reverse(pats));
......@@ -331,7 +323,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
for(; nonNull(alts); alts=tl(alts)) {
StgPrimAlt alt = hd(alts);
List pats = stgPrimAltPats(alt);
List pats = stgPrimAltVars(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
map1Proc(cgBind,bco,pats);
......@@ -399,7 +391,9 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
}
}
void* itblNames[1000];
#define M_ITBLNAMES 35000
void* itblNames[M_ITBLNAMES];
int nItblNames = 0;
/* allocate space for top level variable
......@@ -420,7 +414,8 @@ static Void alloc( AsmBCO bco, StgVar v )
} else {
void* vv = stgConInfo(con);
assert (nItblNames < (1000-2));
if (!(nItblNames < (M_ITBLNAMES-2)))
internal("alloc -- M_ITBLNAMES too small");
if (isName(con)) {
itblNames[nItblNames++] = vv;
itblNames[nItblNames++] = textToStr(name(con).text);
......@@ -438,9 +433,21 @@ static Void alloc( AsmBCO bco, StgVar v )
}
break;
}
case STGAPP:
setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
case STGAPP: {
Int totSizeW = 0;
List bs = stgAppArgs(rhs);
for (; nonNull(bs); bs=tl(bs)) {
if (isName(hd(bs))) {
totSizeW += 1;
} else {
ASSERT(whatIs(hd(bs))==STGVAR);
totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
}
}
setPos(v,asmAllocAP(bco,totSizeW));
//ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
break;
}
case LAMBDA: /* optimisation */
setObj(v,cgLambda(rhs));
break;
......@@ -548,6 +555,7 @@ static void beginTop( StgVar v )
{
StgRhs rhs;
assert(isStgVar(v));
currentTop = v;
rhs = stgVarBody(v);
switch (whatIs(rhs)) {
case STGCON:
......@@ -557,7 +565,11 @@ static void beginTop( StgVar v )
break;
}
case LAMBDA:
#ifdef CRUDE_PROFILING
setObj(v,asmBeginBCO(currentTop));
#else
setObj(v,asmBeginBCO(rhs));