From 9da01c710daee2cd5038afb8fad761cdaf343033 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 9 Mar 1999 14:51:30 +0000 Subject: [PATCH] [project @ 1999-03-09 14:51:03 by sewardj] Many improvements resulting from first attempt to run nofib suite: -- More libraries (lib/*.hs) brought into operation -- Prelude error handling and basic I/O improved -- Changed bytecode immediate value fields so large constant -- tables can be compiled -- Fixed bugs: translation of FATBAR, negative floating point -- literals, strict constructors, handling of CAFs --- ghc/interpreter/Makefile | 101 +- ghc/interpreter/backend.h | 7 +- ghc/interpreter/codegen.c | 33 +- ghc/interpreter/compiler.c | 9 +- ghc/interpreter/connect.h | 7 +- ghc/interpreter/derive.c | 82 +- ghc/interpreter/hugs.c | 49 +- ghc/interpreter/lib/Array.hs | 85 ++ ghc/interpreter/lib/Char.hs | 25 + ghc/interpreter/lib/Complex.hs | 94 ++ ghc/interpreter/lib/Ix.hs | 15 + ghc/interpreter/lib/List.hs | 267 +++++ ghc/interpreter/lib/Maybe.hs | 41 + ghc/interpreter/lib/Monad.hs | 97 ++ ghc/interpreter/lib/Prelude.hs | 2093 ++++++++++++++++++++++++++++++++++++++++ ghc/interpreter/lib/Ratio.hs | 13 + ghc/interpreter/link.c | 119 ++- ghc/interpreter/link.h | 6 +- ghc/interpreter/optimise.c | 31 +- ghc/interpreter/parser.y | 6 +- ghc/interpreter/static.c | 28 +- ghc/interpreter/stg.c | 14 +- ghc/interpreter/storage.c | 126 +-- ghc/interpreter/storage.h | 32 +- ghc/interpreter/translate.c | 83 +- ghc/interpreter/type.c | 14 +- ghc/lib/hugs/Prelude.hs | 2093 ++++++++++++++++++++++++++++++++++++++++ ghc/rts/Assembler.c | 452 ++++++--- ghc/rts/Bytecodes.h | 20 +- ghc/rts/Disassembler.c | 115 ++- ghc/rts/Evaluator.c | 423 ++++---- ghc/rts/Printer.c | 13 +- 32 files changed, 5871 insertions(+), 722 deletions(-) create mode 100644 ghc/interpreter/lib/Array.hs create mode 100644 ghc/interpreter/lib/Char.hs create mode 100644 ghc/interpreter/lib/Complex.hs create mode 100644 ghc/interpreter/lib/Ix.hs create mode 100644 ghc/interpreter/lib/List.hs create mode 100644 ghc/interpreter/lib/Maybe.hs create mode 100644 ghc/interpreter/lib/Monad.hs create mode 100644 ghc/interpreter/lib/Prelude.hs create mode 100644 ghc/interpreter/lib/Ratio.hs create mode 100644 ghc/lib/hugs/Prelude.hs diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile index d14b34f..c7d5d20 100644 --- a/ghc/interpreter/Makefile +++ b/ghc/interpreter/Makefile @@ -1,6 +1,6 @@ # ----------------------------------------------------------------------------- # -# $Id: Makefile,v 1.5 1999/03/01 14:58:56 sewardj Exp $ # +# $Id: Makefile,v 1.6 1999/03/09 14:51:03 sewardj Exp $ # # ----------------------------------------------------------------------------- # TOP = ../.. @@ -26,17 +26,16 @@ 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 -SRC_CC_OPTS = -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wstrict-prototypes -D_POSIX_C_SOURCE +SRC_CC_OPTS = -O2 -Winline -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wstrict-prototypes 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 -###all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs Prelude.hs all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs ### EXTREMELY hacky -hugs: $(C_OBJS) ../rts/Assembler.o ../rts/Disassembler.o ../rts/Evaluator.o ../rts/ForeignCall.o \ +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 @@ -55,98 +54,12 @@ cleanish: snapshot: /bin/rm -f snapshot.tar - tar cvf snapshot.tar Makefile Prelude.hs *.[chy] *-ORIG-* \ + tar cvf snapshot.tar Makefile *.[chy] *-ORIG-* \ ../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \ ../rts/ForeignCall.c ../rts/Printer.c \ ../includes/options.h ../includes/Assembler.h nHandle.c \ - ../includes/Assembler.h ../rts/Bytecodes.h - -# --------------------------------------------------------------------- # -# Prelude # -# --------------------------------------------------------------------- # - -# HPPFLAGS += "-DBEGIN_FOR_HUGS={-" -# HPPFLAGS += "-DEND_FOR_HUGS=-}" - -CPPFLAGS += -I$(GHC_DIR)/includes -CPPFLAGS += -D__HUGS__ -HPP = gcc -E -P -traditional -xc -DSTD_PRELUDE=0 $(HPPFLAGS) $(CPPFLAGS) -Iprelude -Ilibrary -I. -UNLIT = ../utils/unlit/unlit - -# we cleanup by deleting adjacent blank lines - which just happen to be the -# only duplicate adjacent lines in all the files we process -CLEANUP = uniq - -# Fiendishly cunning this: -# o PreludeBuiltin.hs contains the BODY of the libraries it requires. -# o All the other libraries just contain the HEAD of the file. -Prelude.hs : $(wildcard prelude/*.hs) $(wildcard library/*.hs) $(wildcard ../lib/*/*.lhs) - echo Building PreludeBuiltin - $(HPP) ../lib/std/PrelHandle.lhs | $(UNLIT) - PrelHandle.unlit - $(HPP) ../lib/std/PrelIOBase.lhs | $(UNLIT) - PrelIOBase.unlit - $(HPP) ../lib/std/PrelException.lhs | $(UNLIT) - PrelException.unlit - $(HPP) ../lib/std/PrelDynamic.lhs | $(UNLIT) - PrelDynamic.unlit - $(HPP) -DBODY ../lib/std/IO.lhs | $(UNLIT) - IO.unlit - $(HPP) -DHEAD ../lib/std/IO.lhs | $(UNLIT) - IO.hs - $(HPP) -DBODY prelude/Prelude.hs | $(CLEANUP) > PreludeBuiltin.hs - $(HPP) -DHEAD prelude/Prelude.hs | $(CLEANUP) > Prelude.hs - $(HPP) -DHEAD library/Array.hs | $(CLEANUP) > Array.hs - $(HPP) -DHEAD library/Char.hs | $(CLEANUP) > Char.hs - $(HPP) -DHEAD library/Ix.hs | $(CLEANUP) > Ix.hs - $(HPP) -DHEAD library/List.hs | $(CLEANUP) > List.hs - $(HPP) -DHEAD library/Maybe.hs | $(CLEANUP) > Maybe.hs - $(HPP) -DHEAD library/Numeric.hs | $(CLEANUP) > Numeric.hs - $(HPP) -DHEAD library/Ratio.hs | $(CLEANUP) > Ratio.hs - $(HPP) -DHEAD library/UnicodePrims.hs| $(CLEANUP) > UnicodePrims.hs - $(HPP) -DHEAD prelude/PreludeIO.hs | $(CLEANUP) > PreludeIO.hs - $(HPP) -DHEAD prelude/PreludeList.hs | $(CLEANUP) > PreludeList.hs - $(HPP) -DHEAD prelude/PreludeText.hs | $(CLEANUP) > PreludeText.hs - $(HPP) -DHEAD prelude/PrelConc.hs | $(CLEANUP) > PrelConc.hs - echo "Building standard libraries" - $(HPP) library/Complex.hs > Complex.hs - $(HPP) library/Monad.hs > Monad.hs - $(HPP) ../lib/std/System.lhs > System.lhs - $(HPP) ../lib/std/Directory.lhs > Directory.lhs - $(HPP) ../lib/std/Locale.lhs > Locale.lhs - $(HPP) ../lib/std/Random.lhs > Random.lhs - $(HPP) ../lib/std/CPUTime.lhs > CPUTime.lhs - $(HPP) ../lib/std/Time.lhs > Time.lhs - echo "And some standard libraries which ain't done yet" - # $(HPP) library/IO.hs > IO.hs - # - echo "Building Hugs-GHC libraries" - $(HPP) ../lib/exts/ST.lhs > ST.lhs - $(HPP) ../lib/misc/Pretty.lhs > Pretty.lhs - $(HPP) ../lib/exts/IOExts.lhs > IOExts.lhs - $(HPP) ../lib/exts/NumExts.lhs > NumExts.lhs - $(HPP) ../lib/exts/Dynamic.lhs > Dynamic.lhs - $(HPP) ../lib/exts/Bits.lhs > Bits.lhs - $(HPP) ../lib/exts/Exception.lhs > Exception.lhs - $(HPP) library/Int.hs > Int.hs - $(HPP) library/Word.hs > Word.hs - $(HPP) ../lib/exts/Addr.lhs > Addr.lhs - $(HPP) ../lib/concurrent/Channel.lhs > Channel.lhs - $(HPP) ../lib/concurrent/ChannelVar.lhs > ChannelVar.lhs - $(HPP) ../lib/concurrent/Concurrent.lhs > Concurrent.lhs - $(HPP) ../lib/concurrent/Merge.lhs > Merge.lhs - $(HPP) ../lib/concurrent/SampleVar.lhs > SampleVar.lhs - $(HPP) ../lib/concurrent/Semaphore.lhs > Semaphore.lhs - echo "And some libraries which ain't converted yet" - # $(HPP) ../lib/exts/Foreign.lhs > Foreign.lhs - # - # $(HPP) ../lib/concurrent/Parallel.lhs > Parallel.lhs - -prelclean: - $(RM) Array.hs Dynamic.lhs NumExts.lhs Pretty.lhs - $(RM) Bits.lhs Exception.lhs Numeric.hs Ratio.hs - $(RM) Channel.lhs IOExts.lhs PrelConc.hs ST.lhs - $(RM) ChannelVar.lhs Ix.hs Prelude.hs SampleVar.lhs - $(RM) Char.hs List.hs PreludeBuiltin.hs Semaphore.lhs - $(RM) Complex.hs Maybe.hs PreludeIO.hs System.lhs - $(RM) Concurrent.lhs Merge.lhs PreludeList.hs UnicodePrims.hs - $(RM) Directory.lhs Monad.hs PreludeText.hs - $(RM) Locale.lhs Int.hs IO.hs Addr.lhs Time.lhs Word.hs - $(RM) *.unlit + ../includes/Assembler.h ../rts/Bytecodes.h \ + lib/*.hs # --------------------------------------------------------------------- # @@ -176,8 +89,6 @@ CLEAN_FILES += parser.c INSTALL_LIBEXECS = hugs -###clean :: prelclean - depend :: $(LOOPS) $(SRCS_UGNHS) diff --git a/ghc/interpreter/backend.h b/ghc/interpreter/backend.h index b314382..5334454 100644 --- a/ghc/interpreter/backend.h +++ b/ghc/interpreter/backend.h @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: backend.h,v $ - * $Revision: 1.2 $ - * $Date: 1999/03/01 14:46:42 $ + * $Revision: 1.3 $ + * $Date: 1999/03/09 14:51:04 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -129,9 +129,6 @@ extern Bool isAtomic ( StgRhs rhs ); extern StgVar mkStgVar ( StgRhs rhs, Cell info ); -#define mkSeq(x,y) mkStgCase(mkStgApp(nameForce,singleton(x)),singleton(mkStgDefault(mkStgVar(NIL,NIL),y))) - - #define mkStgRep(c) mkChar(c) /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index 5ef8e28..4205951 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: codegen.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:42 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:04 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -636,22 +636,25 @@ Void cgBinds( List binds ) List b; int i; - //if (lastModule() != modulePrelude) { - // printf("\n\ncgBinds: before ll\n\n" ); - // for (b=binds; nonNull(b); b=tl(b)) { - // printStg ( stdout, hd(b) ); printf("\n\n"); - // } - //} +#if 0 + if (lastModule() != modulePrelude) { + printf("\n\ncgBinds: before ll\n\n" ); + for (b=binds; nonNull(b); b=tl(b)) { + printStg ( stdout, hd(b) ); printf("\n\n"); + } + } +#endif binds = liftBinds(binds); - //if (lastModule() != modulePrelude) { - // printf("\n\ncgBinds: after ll\n\n" ); - // for (b=binds; nonNull(b); b=tl(b)) { - // printStg ( stdout, hd(b) ); printf("\n\n"); - // } - //} - +#if 0 + if (lastModule() != modulePrelude) { + printf("\n\ncgBinds: after ll\n\n" ); + for (b=binds; nonNull(b); b=tl(b)) { + printStg ( stdout, hd(b) ); printf("\n\n"); + } + } +#endif //mapProc(beginTop,binds); for (b=binds,i=0; nonNull(b); b=tl(b),i++) { diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index a0481f0..7591e78 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -10,8 +10,8 @@ * in the distribution for details. * * $RCSfile: compiler.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:43 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:05 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1500,7 +1500,6 @@ Void evalExp() { /* compile and run input expression */ RevertCAFs(); break; case Success: - /* Nothing to do */ break; default: internal("evalExp: Unrecognised SchedulerStatus"); @@ -1535,7 +1534,6 @@ Void compileDefns() { /* compile script definitions */ /* a nasty hack. But I don't know an easier way to make */ /* these things appear. */ if (lastModule() == modulePrelude) { - //printf ( "------ Adding cons (:) [] () \n" ); implementCfun ( nameCons, NIL ); implementCfun ( nameNil, NIL ); implementCfun ( nameUnit, NIL ); @@ -1583,8 +1581,9 @@ Void compileDefns() { /* compile script definitions */ /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */ binds = addGlobals(binds); #if USE_HUGS_OPTIMIZER - mapProc(optimiseBind,binds); #error optimiser + if (lastModule() != modulePrelude) + mapProc(optimiseTopBind,binds); #endif stgCGBinds(binds); diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 0f59e3c..75b86a7 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -7,8 +7,8 @@ * in the distribution for details. * * $RCSfile: connect.h,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:43 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:05 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -17,7 +17,6 @@ extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/ extern Module modulePrelude; -//extern Module modulePreludeHugs; /* -------------------------------------------------------------------------- * Primitive constructor functions @@ -173,7 +172,7 @@ extern Float whnfFloat; /* float value of term in whnf */ extern Long numCells; /* number of cells allocated */ extern Int numGcs; /* number of garbage collections */ extern Bool broken; /* indicates interrupt received */ -/*ToDo?? extern Bool preludeLoaded;*/ /* TRUE => prelude has been loaded */ +extern Bool preludeLoaded; /* TRUE => prelude has been loaded */ extern Bool gcMessages; /* TRUE => print GC messages */ extern Bool literateScripts; /* TRUE => default lit scripts */ diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c index cb2c925..d4dcdbd 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: derive.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:44 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:06 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -19,6 +19,7 @@ #include "Assembler.h" #include "link.h" +#if 0 static Cell varTrue; static Cell varFalse; #if DERIVE_ORD @@ -64,7 +65,6 @@ static Cell varGt; #endif #if DERIVE_SHOW || DERIVE_READ static Cell varAppend; /* list append */ -List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ #endif #if DERIVE_EQ || DERIVE_IX static Cell varAnd; /* built-in logical connectives */ @@ -72,7 +72,9 @@ static Cell varAnd; /* built-in logical connectives */ #if DERIVE_EQ || DERIVE_ORD static Cell varEq; #endif +#endif /* 0 */ +List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ /* -------------------------------------------------------------------------- * local function prototypes: @@ -202,12 +204,12 @@ Type t; { /* for some TUPLE or DATATYPE t */ List cs = tycon(t).defn; for (; hasCfun(cs); cs=tl(cs)) { alts = cons(mkAltEq(tycon(t).line, - makeDPats2(hd(cs),name(hd(cs)).arity)), + makeDPats2(hd(cs),userArity(hd(cs)))), alts); } if (cfunOf(hd(tycon(t).defn))!=0) { alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)), - pair(mkInt(tycon(t).line),varFalse)),alts); + pair(mkInt(tycon(t).line),nameFalse)),alts); } alts = rev(alts); } else { /* special case for tuples */ @@ -221,12 +223,12 @@ Int line; /* using patterns in pats for lhs */ List pats; { /* arguments */ Cell p = hd(pats); Cell q = hd(tl(pats)); - Cell e = varTrue; + Cell e = nameTrue; if (isAp(p)) { - e = ap2(varEq,arg(p),arg(q)); + e = ap2(nameEq,arg(p),arg(q)); for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) { - e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e); + e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e); } } return pair(pats,pair(mkInt(line),e)); @@ -246,18 +248,18 @@ Type t; { /* for some TUPLE or DATATYPE t */ Cell rhs = NIL; if (cfunOf(hd(tycon(t).defn))!=0) { implementConToTag(t); - rhs = ap2(varCompare, + rhs = ap2(nameCompare, ap(tycon(t).conToTag,u), ap(tycon(t).conToTag,w)); } else { - rhs = varEQ; + rhs = nameEQ; } alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs))); } else if (isTycon(t)) { /* deal with type constrs */ List cs = tycon(t).defn; for (; hasCfun(cs); cs=tl(cs)) { alts = cons(mkAltOrd(tycon(t).line, - makeDPats2(hd(cs),name(hd(cs)).arity)), + makeDPats2(hd(cs),userArity(hd(cs)))), alts); } if (cfunOf(hd(tycon(t).defn))!=0) { @@ -266,7 +268,7 @@ Type t; { /* for some TUPLE or DATATYPE t */ implementConToTag(t); alts = cons(pair(doubleton(u,w), pair(mkInt(tycon(t).line), - ap2(varCompare, + ap2(nameCompare, ap(tycon(t).conToTag,u), ap(tycon(t).conToTag,w)))), alts); @@ -283,12 +285,12 @@ Int line; /* using patterns in pats for lhs */ List pats; { /* arguments */ Cell p = hd(pats); Cell q = hd(tl(pats)); - Cell e = varEQ; + Cell e = nameEQ; if (isAp(p)) { - e = ap2(varCompare,arg(p),arg(q)); + e = ap2(nameCompare,arg(p),arg(q)); for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) { - e = ap3(varCompAux,arg(p),arg(q),e); + e = ap3(nameCompAux,arg(p),arg(q),e); } } @@ -304,11 +306,11 @@ List pats; { /* arguments */ #if DERIVE_ENUM List deriveEnum(t) /* Construct definition of enumeration */ Tycon t; { - Int l = tycon(t).line; - Cell x = inventVar(); - Cell y = inventVar(); + Int l = tycon(t).line; + Cell x = inventVar(); + Cell y = inventVar(); Cell first = hd(tycon(t).defn); - Cell last = tycon(t).defn; + Cell last = tycon(t).defn; if (!isEnumType(t)) { ERRMSG(l) "Can only derive instances of Enum for enumeration types" @@ -324,12 +326,12 @@ Tycon t; { cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)), cons(mkBind("enumFrom", singleton(pair(singleton(x), pair(mkInt(l), - ap2(varEnumFromTo,x,last))))), + ap2(nameFromTo,x,last))))), /* default instance of enumFromTo is good */ cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y), pair(mkInt(l), - ap3(varEnumFromThenTo,x,y, - ap(COND,triple(ap2(varLe,x,y), + ap3(nameFromThenTo,x,y, + ap(COND,triple(ap2(nameLe,x,y), last,first))))))), /* default instance of enumFromThenTo is good */ NIL)))); @@ -354,7 +356,7 @@ Tycon t; { } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) { return mkIxBinds(tycon(t).line, hd(tycon(t).defn), - name(hd(tycon(t).defn)).arity); + userArity(hd(tycon(t).defn))); } ERRMSG(tycon(t).line) "Can only derive instances of Ix for enumeration or product types" @@ -380,21 +382,21 @@ Tycon t; { Cell c2 = inventVar(); Cell ci = inventVar(); return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2), - c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon, - ap2(varEnumFromTo,ap(conToTag,c1), + c1,c2)), pair(mkInt(l),ap2(nameMap,tagToCon, + ap2(nameFromTo,ap(conToTag,c1), ap(conToTag,c2))))))), cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b, ap2(mkTuple(2),c1,c2))),ci), pair(mkInt(l),ap(COND, - triple(ap2(varInRange,b,ci), - ap2(qvarMinus,ap(conToTag,ci), + triple(ap2(nameInRange,b,ci), + ap2(nameMinus,ap(conToTag,ci), ap(conToTag,c1)), - ap(varError,mkStr(findText( + ap(nameError,mkStr(findText( "Ix.index: Index out of range"))))))))), cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2), - c1,c2),ci), pair(mkInt(l),ap2(varAnd, - ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)), - ap2(varLe,ap(conToTag,ci), + c1,c2),ci), pair(mkInt(l),ap2(nameAnd, + ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)), + ap2(nameLe,ap(conToTag,ci), ap(conToTag,c2))))))), /* ToDo: share conToTag ci */ NIL))); @@ -438,7 +440,7 @@ Cell ls, us, is; { List e = NIL; for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) { e = cons(ap(FROMQUAL,pair(arg(is), - ap(varRange,ap2(mkTuple(2), + ap(nameRange,ap2(mkTuple(2), arg(ls), arg(us))))),e); } @@ -460,11 +462,11 @@ Cell ls, us, is; { List xs = NIL; Cell e = NIL; for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) { - xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs); + xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs); } for (e=hd(xs); nonNull(xs=tl(xs));) { Cell x = hd(xs); - e = ap2(qvarPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e)); + e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e)); } e = singleton(pair(pats,pair(mkInt(line),e))); return mkBind("index",e); @@ -478,10 +480,10 @@ Cell ls, us, is; { * inRange (X a b c, X p q r) (X x y z) * = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z */ - Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)); + Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)); while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) { - e = ap2(varAnd, - ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)), + e = ap2(nameAnd, + ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)), e); } e = singleton(pair(pats,pair(mkInt(line),e))); @@ -1004,7 +1006,7 @@ Tycon t; { /* \ v -> case v of { ...; i -> Ci; ... } */ Void implementTagToCon(t) -Tycon t; { +Tycon t; { if (isNull(tycon(t).tagToCon)) { String etxt; String tyconname; @@ -1091,6 +1093,7 @@ 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 @@ -1143,6 +1146,7 @@ Int what; { #if DERIVE_EQ || DERIVE_ORD varEq = mkQVar(textPrelude,findText("==")); #endif +#endif /* 0 */ /* deliberate fall through */ case RESET : diVars = NIL; @@ -1157,6 +1161,7 @@ Int what; { #if DERIVE_SHOW | DERIVE_READ mark(cfunSfuns); #endif +#if 0 mark(varTrue); mark(varFalse); #if DERIVE_ORD @@ -1209,6 +1214,7 @@ Int what; { #if DERIVE_EQ || DERIVE_ORD mark(varEq); #endif +#endif /* 0 */ break; } } diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 08dfe07..ade1335 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: hugs.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:45 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:07 $ * ------------------------------------------------------------------------*/ #include @@ -112,7 +112,6 @@ static Bool quiet = FALSE; /* TRUE => don't show progress */ static String scriptName[NUM_SCRIPTS]; /* Script file names */ static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */ static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */ -static Int scriptBase; /* Number of scripts in Prelude */ static Int numScripts; /* Number of scripts loaded */ static Int namesUpto; /* Number of script names set */ static Bool needsImports; /* set to TRUE if imports required */ @@ -126,8 +125,9 @@ 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 */ + 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? */ @@ -216,7 +216,7 @@ String argv[]; { readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options","")); readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options","")); #endif /* USE_REGISTRY */ - readOptions(fromEnv("HUGSFLAGS","")); + readOptions(fromEnv("STGHUGSFLAGS","")); startupHaskell ( argc, argv ); argc = prog_argc; argv = prog_argv; @@ -262,7 +262,6 @@ String argv[]; { loadProject(strCopy(proj)); } readScripts(0); - scriptBase = numScripts; } /* -------------------------------------------------------------------------- @@ -483,7 +482,7 @@ String s; { /* return FALSE if none found. */ case 'h' : setHeapSize(s+1); return TRUE; - case 'd' : /* hack */ + case 'D' : /* hack */ { extern void setRtsFlags( int x ); setRtsFlags(argToInt(s+1)); @@ -701,7 +700,7 @@ String s; { currProject = s; projInput(currProject); scriptFile = currProject; - forgetScriptsFrom(scriptBase); + forgetScriptsFrom(1); while ((s=readFilename())!=0) addScriptName(s,TRUE); if (namesUpto<=1) { @@ -764,6 +763,7 @@ ToDo: reinstate } #endif scriptFile = 0; + preludeLoaded = TRUE; return TRUE; } @@ -822,7 +822,7 @@ Script scno; { for (i=scno; inamesUpto) numScripts = scno; @@ -837,7 +837,7 @@ static Void local load() { /* read filenames from command line */ /* to be read */ while ((s=readFilename())!=0) addScriptName(s,TRUE); - readScripts(scriptBase); + readScripts(1); } static Void local project() { /* read list of script names from */ @@ -858,7 +858,7 @@ static Void local project() { /* read list of script names from */ EEND; } loadProject(s); - readScripts(scriptBase); + readScripts(1); } static Void local readScripts(n) /* Reread current list of scripts, */ @@ -873,7 +873,7 @@ Int n; { /* loading everything after and */ for (; n0) /* no new script for prelude */ + startNewScript(scriptName[numScripts]); if (addScript(scriptName[numScripts],fileSize)) numScripts++; else - dropScriptsFrom(numScripts); + dropScriptsFrom(numScripts-1); } if (listScripts) whatScripts(); - if (numScripts<=scriptBase) + if (numScripts<=1) setLastEdit((String)0, 0); } @@ -940,11 +941,11 @@ static Void local find() { /* edit file containing definition */ startNewScript(0); if (nonNull(c=findTycon(t=findText(nm)))) { if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) { - readScripts(scriptBase); + readScripts(1); } } else if (nonNull(c=findName(t))) { if (startEdit(name(c).line,scriptName[scriptThisName(c)])) { - readScripts(scriptBase); + readScripts(1); } } else { ERRMSG(0) "No current definition for name \"%s\"", nm @@ -955,7 +956,7 @@ static Void local find() { /* edit file containing definition */ static Void local runEditor() { /* run editor on script lastEdit */ if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */ - readScripts(scriptBase); + readScripts(1); } static Void local setLastEdit(fname,line)/* keep name of last file to edit */ @@ -1451,7 +1452,8 @@ String argv[]; { for (;;) { Command cmd; everybody(RESET); /* reset to sensible initial state */ - dropScriptsFrom(numScripts); /* remove partially loaded scripts */ + dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */ + /* not counting prelude as a script*/ promptForInput(textToStr(module(findEvalModule()).text)); @@ -1465,14 +1467,14 @@ String argv[]; { case FIND : find(); break; case LOAD : clearProject(); - forgetScriptsFrom(scriptBase); + forgetScriptsFrom(1); load(); break; case ALSO : clearProject(); forgetScriptsFrom(numScripts); load(); break; - case RELOAD : readScripts(scriptBase); + case RELOAD : readScripts(1); break; case PROJECT: project(); break; @@ -1869,16 +1871,15 @@ Int what; { /* system to respond as appropriate ... */ storage(what); /* important for the INSTALL command */ substitution(what); input(what); + translateControl(what); linkControl(what); staticAnalysis(what); deriveControl(what); typeChecker(what); - translateControl(what); compiler(what); codegen(what); } - /* -------------------------------------------------------------------------- * Hugs for Windows code (WinMain and related functions) * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/lib/Array.hs b/ghc/interpreter/lib/Array.hs new file mode 100644 index 0000000..a3e9d42 --- /dev/null +++ b/ghc/interpreter/lib/Array.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- Standard Library: Array operations +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module Array ( + module Ix, -- export all of Ix + Array, array, listArray, (!), bounds, indices, elems, assocs, + accumArray, (//), accum, ixmap ) where + +import Ix +import List( (\\) ) + +infixl 9 !, // + +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 + { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom + ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs + ; arr <- primUnsafeFreezeArray mut_arr + ; return (Array ixs arr) + } + ) + where + arrEleBottom = error "(Array.!): undefined array element" + +listArray :: Ix a => (a,a) -> [b] -> Array a b +listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs) + +(!) :: Ix a => Array a b -> a -> b +(Array bounds arr) ! i = primIndexArray arr (index bounds i) + +bounds :: Ix a => Array a b -> (a,a) +bounds (Array b _) = b + +indices :: Ix a => Array a b -> [a] +indices = range . bounds + +elems :: Ix a => Array a b -> [b] +elems a = [a!i | i <- indices a] + +assocs :: Ix a => Array a b -> [(a,b)] +assocs a = [(i, a!i) | i <- indices a] + +(//) :: Ix a => Array a b -> [(a,b)] -> Array a b +a // us = array (bounds a) + ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]] + ++ us) + +accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b +accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)]) + +accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +accumArray f z b = accum f (array b [(i,z) | i <- range b]) + +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c +ixmap b f a = array b [(i, a ! f i) | i <- range b] + + +instance (Ix a) => Functor (Array a) where + fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a] + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Char.hs b/ghc/interpreter/lib/Char.hs new file mode 100644 index 0000000..dc2d256 --- /dev/null +++ b/ghc/interpreter/lib/Char.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- Standard Library: Char operations +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module Char ( + isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower, + isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, + digitToInt, intToDigit, + toUpper, toLower, + ord, chr, + readLitChar, showLitChar, lexLitChar, + + -- ... and what the prelude exports + Char, String + ) where + +-- This module is (almost) empty; Char operations are currently defined in +-- the prelude, but should eventually be moved to this library file instead. +-- No Unicode support yet. + +isLatin1 c = True + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Complex.hs b/ghc/interpreter/lib/Complex.hs new file mode 100644 index 0000000..4f54283 --- /dev/null +++ b/ghc/interpreter/lib/Complex.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- Standard Library: Complex numbers +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar, + cis, polar, magnitude, phase) where + +infix 6 :+ + +data (RealFloat a) => Complex a = !a :+ !a + deriving (Eq,Read,Show) + +realPart, imagPart :: (RealFloat a) => Complex a -> a +realPart (x:+y) = x +imagPart (x:+y) = y + +conjugate :: (RealFloat a) => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +mkPolar :: (RealFloat a) => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +cis :: (RealFloat a) => a -> Complex a +cis theta = cos theta :+ sin theta + +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +magnitude, phase :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2)) + where k = max (exponent x) (exponent y) + mk = - k +phase (0:+0) = 0 +phase (x:+y) = atan2 y x + +instance (RealFloat a) => Num (Complex a) where + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 + fromInt n = fromInt n :+ 0 + +instance (RealFloat a) => Fractional (Complex a) where + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + fromRational a = fromRational a :+ 0 + fromDouble a = fromDouble a :+ 0 + +instance (RealFloat a) => Floating (Complex a) where + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + sqrt 0 = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z@(x:+y) = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Ix.hs b/ghc/interpreter/lib/Ix.hs new file mode 100644 index 0000000..9d9531a --- /dev/null +++ b/ghc/interpreter/lib/Ix.hs @@ -0,0 +1,15 @@ +----------------------------------------------------------------------------- +-- Standard Library: Ix operations +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module Ix ( + -- official Haskell 98 interface: Ix(range, index, inRange), rangeSize + Ix(range, index, inRange, rangeSize) + ) where + +-- This module is empty; Ix is currently defined in the prelude, but should +-- eventually be moved to this library file instead. + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/List.hs b/ghc/interpreter/lib/List.hs new file mode 100644 index 0000000..bb10d13 --- /dev/null +++ b/ghc/interpreter/lib/List.hs @@ -0,0 +1,267 @@ +----------------------------------------------------------------------------- +-- Standard Library: List operations +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module List ( + elemIndex, elemIndices, + find, findIndex, findIndices, + nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy, + union, unionBy, intersect, intersectBy, + intersperse, transpose, partition, group, groupBy, + inits, tails, isPrefixOf, isSuffixOf, + mapAccumL, mapAccumR, + sort, sortBy, insert, insertBy, maximumBy, minimumBy, + genericLength, genericTake, genericDrop, + genericSplitAt, genericIndex, genericReplicate, + zip4, zip5, zip6, zip7, + zipWith4, zipWith5, zipWith6, zipWith7, + unzip4, unzip5, unzip6, unzip7, unfoldr, + + -- ... and what the Prelude exports + -- List type: []((:), []) + (:), + map, (++), concat, filter, + head, last, tail, init, null, length, (!!), + foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, + iterate, repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, + lines, words, unlines, unwords, reverse, and, or, + any, all, elem, notElem, lookup, + sum, product, maximum, minimum, concatMap, + zip, zip3, zipWith, zipWith3, unzip, unzip3 + ) where + +import Maybe( listToMaybe ) + +infix 5 \\ + +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x ==) + +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x ==) + +find :: (a -> Bool) -> [a] -> Maybe a +find p = listToMaybe . filter p + +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p = listToMaybe . findIndices p + +findIndices :: (a -> Bool) -> [a] -> [Int] +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ] + +nub :: (Eq a) => [a] -> [a] +nub = nubBy (==) + +nubBy :: (a -> a -> Bool) -> [a] -> [a] +nubBy eq [] = [] +nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs) + +delete :: (Eq a) => a -> [a] -> [a] +delete = deleteBy (==) + +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy eq x [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + +union :: (Eq a) => [a] -> [a] -> [a] +union = unionBy (==) + +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +intersect :: (Eq a) => [a] -> [a] -> [a] +intersect = intersectBy (==) + +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +intersperse :: a -> [a] -> [a] +intersperse sep [] = [] +intersperse sep [x] = [x] +intersperse sep (x:xs) = x : sep : intersperse sep xs + +transpose :: [[a]] -> [[a]] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : + transpose (xs : [ t | (h:t) <- xss]) + +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p xs = foldr select ([],[]) xs + where select x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts,x:fs) + +-- group splits its list argument into a list of lists of equal, adjacent +-- elements. e.g., +-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"] +group :: (Eq a) => [a] -> [[a]] +group = groupBy (==) + +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy eq [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- inits xs returns the list of initial segments of xs, shortest first. +-- e.g., inits "abc" == ["","a","ab","abc"] +inits :: [a] -> [[a]] +inits [] = [[]] +inits (x:xs) = [[]] ++ map (x:) (inits xs) + +-- tails xs returns the list of all final segments of xs, longest first. +-- e.g., tails "abc" == ["abc", "bc", "c",""] +tails :: [a] -> [[a]] +tails [] = [[]] +tails xxs@(_:xs) = xxs : tails xs + +isPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys) = x == y && isPrefixOf xs ys + +isSuffixOf :: (Eq a) => [a] -> [a] -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y + +mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccumL f s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccumR f s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + +unfoldr :: (b -> Maybe (a,b)) -> b -> [a] +unfoldr f b = case f b of Nothing -> [] + Just (a,b) -> a : unfoldr f b + +sort :: (Ord a) => [a] -> [a] +sort = sortBy compare + +sortBy :: (a -> a -> Ordering) -> [a] -> [a] +sortBy cmp = foldr (insertBy cmp) [] + +insert :: (Ord a) => a -> [a] -> [a] +insert = insertBy compare + +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy cmp x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys + +maximumBy :: (a -> a -> a) -> [a] -> a +maximumBy max [] = error "List.maximumBy: empty list" +maximumBy max xs = foldl1 max xs + +minimumBy :: (a -> a -> a) -> [a] -> a +minimumBy min [] = error "List.minimumBy: empty list" +minimumBy min xs = foldl1 min xs + +genericLength :: (Integral a) => [b] -> a +genericLength [] = 0 +genericLength (x:xs) = 1 + genericLength xs + +genericTake :: (Integral a) => a -> [b] -> [b] +genericTake 0 _ = [] +genericTake _ [] = [] +genericTake n (x:xs) + | n > 0 = x : genericTake (n-1) xs + | otherwise = error "List.genericTake: negative argument" + +genericDrop :: (Integral a) => a -> [b] -> [b] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) + | n > 0 = genericDrop (n-1) xs + | otherwise = error "List.genericDrop: negative argument" + +genericSplitAt :: (Integral a) => a -> [b] -> ([b],[b]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) + | n > 0 = (x:xs',xs'') + | otherwise = error "List.genericSplitAt: negative argument" + where (xs',xs'') = genericSplitAt (n-1) xs + +genericIndex :: (Integral a) => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument" +genericIndex _ _ = error "List.genericIndex: index too large" + +genericReplicate :: (Integral a) => a -> b -> [b] +genericReplicate n x = genericTake n (repeat x) + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (,,,) + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (,,,,) + +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [(a,b,c,d,e,f)] +zip6 = zipWith6 (,,,,,) + +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [g] -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (,,,,,,) + +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] + +zipWith5 :: (a->b->c->d->e->f) -> + [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +zipWith6 :: (a->b->c->d->e->f->g) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +zipWith7 :: (a->b->c->d->e->f->g->h) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Maybe.hs b/ghc/interpreter/lib/Maybe.hs new file mode 100644 index 0000000..c1a1ee3 --- /dev/null +++ b/ghc/interpreter/lib/Maybe.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- Standard Library: Operations on the Maybe datatype +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- +module Maybe( + isJust, fromJust, fromMaybe, listToMaybe, maybeToList, + catMaybes, mapMaybe, + + -- ... and what the Prelude exports + Maybe(Nothing, Just), + maybe + ) where + +isJust :: Maybe a -> Bool +isJust (Just a) = True +isJust Nothing = False + +fromJust :: Maybe a -> a +fromJust (Just a) = a +fromJust Nothing = error "Maybe.fromJust: Nothing" + +fromMaybe :: a -> Maybe a -> a +fromMaybe d Nothing = d +fromMaybe d (Just a) = a + +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just a) = [a] + +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:as) = Just a + +catMaybes :: [Maybe a] -> [a] +catMaybes ms = [ m | Just m <- ms ] + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe f = catMaybes . map f + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Monad.hs b/ghc/interpreter/lib/Monad.hs new file mode 100644 index 0000000..4b7cbcb --- /dev/null +++ b/ghc/interpreter/lib/Monad.hs @@ -0,0 +1,97 @@ +----------------------------------------------------------------------------- +-- Standard Library: Monad operations +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module Monad ( + MonadPlus(mzero, mplus), + join, guard, when, unless, ap, + msum, + filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM, + liftM, liftM2, liftM3, liftM4, liftM5, + + -- ... and what the Prelude exports + Monad((>>=), (>>), return, fail), + Functor(fmap), + mapM, mapM_, accumulate, sequence, (=<<), + ) where + +-- The MonadPlus class definition + +class Monad m => MonadPlus m where + mzero :: m a + mplus :: m a -> m a -> m a + +-- Instances of MonadPlus + +instance MonadPlus Maybe where + mzero = Nothing + Nothing `mplus` ys = ys + xs `mplus` ys = xs + +instance MonadPlus [ ] where + mzero = [] + mplus = (++) + +-- Functions + +msum :: MonadPlus m => [m a] -> m a +msum = foldr mplus mzero + +join :: (Monad m) => m (m a) -> m a +join x = x >>= id + +when :: (Monad m) => Bool -> m () -> m () +when p s = if p then s else return () + +unless :: (Monad m) => Bool -> m () -> m () +unless p s = when (not p) s + +ap :: (Monad m) => m (a -> b) -> m a -> m b +ap = liftM2 ($) + +guard :: MonadPlus m => Bool -> m () +guard p = if p then return () else mzero + +mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +mapAndUnzipM f xs = accumulate (map f xs) >>= return . unzip + +zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipWithM f xs ys = accumulate (zipWith f xs ys) + +zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ f xs ys = sequence (zipWith f xs ys) + +foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM f a [] = return a +foldM f a (x:xs) = f a x >>= \ y -> foldM f y xs + +filterM :: MonadPlus m => (a -> m Bool) -> [a] -> m [a] +filterM p [] = return [] +filterM p (x:xs) = do b <- p x + ys <- filterM p xs + return (if b then (x:ys) else ys) + +liftM :: (Monad m) => (a -> b) -> (m a -> m b) +liftM f = \a -> do { a' <- a; return (f a') } + +liftM2 :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c) +liftM2 f = \a b -> do { a' <- a; b' <- b; return (f a' b') } + +liftM3 :: (Monad m) => (a -> b -> c -> d) -> + (m a -> m b -> m c -> m d) +liftM3 f = \a b c -> do { a' <- a; b' <- b; c' <- c; + return (f a' b' c')} + +liftM4 :: (Monad m) => (a -> b -> c -> d -> e) -> + (m a -> m b -> m c -> m d -> m e) +liftM4 f = \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d; + return (f a' b' c' d')} + +liftM5 :: (Monad m) => (a -> b -> c -> d -> e -> f) -> + (m a -> m b -> m c -> m d -> m e -> m f) +liftM5 f = \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d; + e' <- e; return (f a' b' c' d' e')} + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs new file mode 100644 index 0000000..a034776 --- /dev/null +++ b/ghc/interpreter/lib/Prelude.hs @@ -0,0 +1,2093 @@ +{---------------------------------------------------------------------------- +__ __ __ __ ____ ___ _______________________________________________ +|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system +||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999 +||---|| ___|| World Wide Web: http://haskell.org/hugs +|| || Report bugs to: hugs-bugs@haskell.org +|| || Version: January 1999 _______________________________________________ + + This is the Hugs 98 Standard Prelude, based very closely on the Standard + Prelude for Haskell 98. + + WARNING: This file is an integral part of the Hugs source code. Changes to + the definitions in this file without corresponding modifications in other + parts of the program may cause the interpreter to fail unexpectedly. Under + normal circumstances, you should not attempt to modify this file in any way! + +----------------------------------------------------------------------------- + Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell + Group 1994-99, and is distributed as Open Source software under the + Artistic License; see the file "Artistic" that is included in the + distribution for details. +----------------------------------------------------------------------------} + +module Prelude ( +-- module PreludeList, + map, (++), concat, filter, + head, last, tail, init, null, length, (!!), + foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, + iterate, repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, + lines, words, unlines, unwords, reverse, and, or, + any, all, elem, notElem, lookup, + sum, product, maximum, minimum, concatMap, + zip, zip3, zipWith, zipWith3, unzip, unzip3, +-- module PreludeText, + ReadS, ShowS, + Read(readsPrec, readList), + Show(show, showsPrec, showList), + reads, shows, read, lex, + showChar, showString, readParen, showParen, +-- module PreludeIO, + FilePath, IOError, ioError, userError, catch, + putChar, putStr, putStrLn, print, + getChar, getLine, getContents, interact, + readFile, writeFile, appendFile, readIO, readLn, +-- module Ix, + Ix(range, index, inRange, rangeSize), +-- module Char, + isAscii, isControl, isPrint, isSpace, isUpper, isLower, + isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, + digitToInt, intToDigit, + toUpper, toLower, + ord, chr, + readLitChar, showLitChar, lexLitChar, +-- module Numeric + showSigned, showInt, + readSigned, readInt, + readDec, readOct, readHex, readSigned, + readFloat, lexDigits, +-- module Ratio, + Ratio, Rational, (%), numerator, denominator, approxRational, +-- Non-standard exports + IO(..), IOResult(..), Addr, + + Bool(False, True), + Maybe(Nothing, Just), + Either(Left, Right), + Ordering(LT, EQ, GT), + Char, String, Int, Integer, Float, Double, IO, +-- List type: []((:), []) + (:), +-- Tuple types: (,), (,,), etc. +-- Trivial type: () +-- Functions: (->) + Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX + Eq((==), (/=)), + Ord(compare, (<), (<=), (>=), (>), max, min), + Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen, + enumFromTo, enumFromThenTo), + Bounded(minBound, maxBound), +-- Num((+), (-), (*), negate, abs, signum, fromInteger), + Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt), + Real(toRational), +-- Integral(quot, rem, div, mod, quotRem, divMod, toInteger), + Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt), +-- Fractional((/), recip, fromRational), + Fractional((/), recip, fromRational, fromDouble), + Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, + asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, + encodeFloat, exponent, significand, scaleFloat, isNaN, + isInfinite, isDenormalized, isIEEE, isNegativeZero), + Monad((>>=), (>>), return, fail), + Functor(fmap), + mapM, mapM_, accumulate, sequence, (=<<), + maybe, either, + (&&), (||), not, otherwise, + subtract, even, odd, gcd, lcm, (^), (^^), + fromIntegral, realToFrac, atan2, + fst, snd, curry, uncurry, id, const, (.), flip, ($), until, + asTypeOf, error, undefined, + seq, ($!) + + ,primCompAux + ) where + +-- Standard value bindings {Prelude} ---------------------------------------- + +infixr 9 . +infixl 9 !! +infixr 8 ^, ^^, ** +infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, % +infixl 6 +, - +--infixr 5 : -- this fixity declaration is hard-wired into Hugs +infixr 5 ++ +infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem` +infixr 3 && +infixr 2 || +infixl 1 >>, >>= +infixr 1 =<< +infixr 0 $, $!, `seq` + +-- Equality and Ordered classes --------------------------------------------- + +class Eq a where + (==), (/=) :: a -> a -> Bool + + -- Minimal complete definition: (==) or (/=) + x == y = not (x/=y) + x /= y = not (x==y) + +class (Eq a) => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>=), (>) :: a -> a -> Bool + max, min :: a -> a -> a + + -- Minimal complete definition: (<=) or compare + -- using compare can be more efficient for complex types + compare x y | x==y = EQ + | x<=y = LT + | otherwise = GT + + x <= y = compare x y /= GT + x < y = compare x y == LT + x >= y = compare x y /= LT + x > y = compare x y == GT + + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + +class Bounded a where + minBound, maxBound :: a + -- Minimal complete definition: All + +-- Numeric classes ---------------------------------------------------------- + +class (Eq a, Show a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + fromInt :: Int -> a + + -- Minimal complete definition: All, except negate or (-) + x - y = x + negate y + fromInt = fromIntegral + negate x = 0 - x + +class (Num a, Ord a) => Real a where + toRational :: a -> Rational + +class (Real a, Enum a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + even, odd :: a -> Bool + toInteger :: a -> Integer + toInt :: a -> Int + + -- Minimal complete definition: quotRem and toInteger + n `quot` d = q where (q,r) = quotRem n d + n `rem` d = r where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + divMod n d = if signum r == - signum d then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + even n = n `rem` 2 == 0 + odd = not . even + toInt = toInt . toInteger + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + fromDouble :: Double -> a + + -- Minimal complete definition: fromRational and ((/) or recip) + recip x = 1 / x + fromDouble = fromRational . toRational + x / y = x * recip y + + +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh, + -- asinh, acosh, atanh + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + tanh x = sinh x / cosh x + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + -- Minimal complete definition: properFraction + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE + :: a -> Bool + atan2 :: a -> a -> a + + -- Minimal complete definition: All, except exponent, signficand, + -- scaleFloat, atan2 + exponent x = if m==0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + significand x = encodeFloat m (- floatDigits x) + where (m,_) = decodeFloat x + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x + atan2 y x + | x>0 = atan (y/x) + | x==0 && y>0 = pi/2 + | x<0 && y>0 = pi + atan (y/x) + | (x<=0 && y<0) || + (x<0 && isNegativeZero y) || + (isNegativeZero x && isNegativeZero y) + = - atan2 (-y) x + | y==0 && (x<0 || isNegativeZero x) + = pi -- must be after the previous test on zero y + | x==0 && y==0 = y -- must be after the other double zero tests + | otherwise = x + y -- x or y is a NaN, return a NaN (via +) + +-- Numeric functions -------------------------------------------------------- + +subtract :: Num a => a -> a -> a +subtract = flip (-) + +gcd :: Integral a => a -> a -> a +gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) + +lcm :: (Integral a) => a -> a -> a +lcm _ 0 = 0 +lcm 0 _ = 0 +lcm x y = abs ((x `quot` gcd x y) * y) + +(^) :: (Num a, Integral b) => a -> b -> a +x ^ 0 = 1 +x ^ n | n > 0 = f x (n-1) x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n`quot`2) + | otherwise = f x (n-1) (x*y) +_ ^ _ = error "Prelude.^: negative exponent" + +(^^) :: (Fractional a, Integral b) => a -> b -> a +x ^^ n = if n >= 0 then x ^ n else recip (x^(-n)) + +fromIntegral :: (Integral a, Num b) => a -> b +fromIntegral = fromInteger . toInteger + +realToFrac :: (Real a, Fractional b) => a -> b +realToFrac = fromRational . toRational + +-- Index and Enumeration classes -------------------------------------------- + +class (Ord a) => Ix a where + range :: (a,a) -> [a] + index :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + rangeSize :: (a,a) -> Int + + rangeSize r@(l,u) + | l > u = 0 + | otherwise = index r u + 1 + +class Enum a where + succ, pred :: a -> a + toEnum :: Int -> a + fromEnum :: a -> Int + enumFrom :: a -> [a] -- [n..] + enumFromThen :: a -> a -> [a] -- [n,m..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + -- Minimal complete definition: toEnum, fromEnum + succ = toEnum . (1+) . fromEnum + pred = toEnum . subtract 1 . fromEnum + enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ] + enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ] + +-- Read and Show classes ------------------------------------------------------ + +type ReadS a = String -> [(a,String)] +type ShowS = String -> String + +class Read a where + readsPrec :: Int -> ReadS a + readList :: ReadS [a] + + -- Minimal complete definition: readsPrec + readList = readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s ]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- reads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- reads t, + (xs,v) <- readl' u] + +class Show a where + show :: a -> String + showsPrec :: Int -> a -> ShowS + showList :: [a] -> ShowS + + -- Minimal complete definition: show or showsPrec + show x = showsPrec 0 x "" + showsPrec _ x s = show x ++ s + showList [] = showString "[]" + showList (x:xs) = showChar '[' . shows x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showChar ',' . shows x . showl xs + +-- Monad classes ------------------------------------------------------------ + +class Functor f where + fmap :: (a -> b) -> (f a -> f b) + +class Monad m where + return :: a -> m a + (>>=) :: m a -> (a -> m b) -> m b + (>>) :: m a -> m b -> m b + fail :: String -> m a + + -- Minimal complete definition: (>>=), return + p >> q = p >>= \ _ -> q + fail s = error s + +accumulate :: Monad m => [m a] -> m [a] +accumulate [] = return [] +accumulate (c:cs) = do x <- c + xs <- accumulate cs + return (x:xs) + +sequence :: Monad m => [m a] -> m () +sequence = foldr (>>) (return ()) + +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +mapM f = accumulate . map f + +mapM_ :: Monad m => (a -> m b) -> [a] -> m () +mapM_ f = sequence . map f + +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f + +-- Evaluation and strictness ------------------------------------------------ + +seq :: a -> b -> b +seq x y = --case primForce x of () -> y + primSeq x y + +($!) :: (a -> b) -> a -> b +f $! x = x `seq` f x + +-- Trivial type ------------------------------------------------------------- + +-- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded) + +instance Eq () where + () == () = True + +instance Ord () where + compare () () = EQ + +instance Ix () where + range ((),()) = [()] + index ((),()) () = 0 + inRange ((),()) () = True + +instance Enum () where + toEnum 0 = () + fromEnum () = 0 + enumFrom () = [()] + enumFromThen () () = [()] + +instance Read () where + readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ]) + +instance Show () where + showsPrec p () = showString "()" + +instance Bounded () where + minBound = () + maxBound = () + +-- Boolean type ------------------------------------------------------------- + +data Bool = False | True + deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded) + +(&&), (||) :: Bool -> Bool -> Bool +False && x = False +True && x = x +False || x = x +True || x = True + +not :: Bool -> Bool +not True = False +not False = True + +otherwise :: Bool +otherwise = True + +-- Character type ----------------------------------------------------------- + +data Char -- builtin datatype of ISO Latin characters +type String = [Char] -- strings are lists of characters + +instance Eq Char where (==) = primEqChar +instance Ord Char where (<=) = primLeChar + +instance Enum Char where + toEnum = primIntToChar + fromEnum = primCharToInt + enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)] + enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)] + where lastChar = if d < c then minBound else maxBound + +instance Ix Char where + range (c,c') = [c..c'] + index b@(c,c') ci + | inRange b ci = fromEnum ci - fromEnum c + | otherwise = error "Ix.index: Index out of range." + inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c' + where i = fromEnum ci + +instance Read Char where + readsPrec p = readParen False + (\r -> [(c,t) | ('\'':s,t) <- lex r, + (c,"\'") <- readLitChar s ]) + readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, + (l,_) <- readl s ]) + where readl ('"':s) = [("",s)] + readl ('\\':'&':s) = readl s + readl s = [(c:cs,u) | (c ,t) <- readLitChar s, + (cs,u) <- readl t ] +instance Show Char where + showsPrec p '\'' = showString "'\\''" + showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' + + showList cs = showChar '"' . showl cs + where showl "" = showChar '"' + showl ('"':cs) = showString "\\\"" . showl cs + showl (c:cs) = showLitChar c . showl cs + +instance Bounded Char where + minBound = '\0' + maxBound = '\255' + +isAscii, isControl, isPrint, isSpace :: Char -> Bool +isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool + +isAscii c = fromEnum c < 128 +isControl c = c < ' ' || c == '\DEL' +isPrint c = c >= ' ' && c <= '~' +isSpace c = c == ' ' || c == '\t' || c == '\n' || + c == '\r' || c == '\f' || c == '\v' +isUpper c = c >= 'A' && c <= 'Z' +isLower c = c >= 'a' && c <= 'z' +isAlpha c = isUpper c || isLower c +isDigit c = c >= '0' && c <= '9' +isAlphaNum c = isAlpha c || isDigit c + +-- Digit conversion operations +digitToInt :: Char -> Int +digitToInt c + | isDigit c = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10 + | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10 + | otherwise = error "Char.digitToInt: not a digit" + +intToDigit :: Int -> Char +intToDigit i + | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i) + | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10) + | otherwise = error "Char.intToDigit: not a digit" + +toUpper, toLower :: Char -> Char +toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') + | otherwise = c + +toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a') + | otherwise = c + +ord :: Char -> Int +ord = fromEnum + +chr :: Int -> Char +chr = toEnum + +-- Maybe type --------------------------------------------------------------- + +data Maybe a = Nothing | Just a + deriving (Eq, Ord, Read, Show) + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n f Nothing = n +maybe n f (Just x) = f x + +instance Functor Maybe where + fmap f Nothing = Nothing + fmap f (Just x) = Just (f x) + +instance Monad Maybe where + Just x >>= k = k x + Nothing >>= k = Nothing + return = Just + fail s = Nothing + +-- Either type -------------------------------------------------------------- + +data Either a b = Left a | Right b + deriving (Eq, Ord, Read, Show) + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either l r (Left x) = l x +either l r (Right y) = r y + +-- Ordering type ------------------------------------------------------------ + +data Ordering = LT | EQ | GT + deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded) + +-- Lists -------------------------------------------------------------------- + +--data [a] = [] | a : [a] deriving (Eq, Ord) + +instance Eq a => Eq [a] where + [] == [] = True + (x:xs) == (y:ys) = x==y && xs==ys + _ == _ = False + +instance Ord a => Ord [a] where + compare [] (_:_) = LT + compare [] [] = EQ + compare (_:_) [] = GT + compare (x:xs) (y:ys) = primCompAux x y (compare xs ys) + +instance Functor [] where + fmap = map + +instance Monad [ ] where + (x:xs) >>= f = f x ++ (xs >>= f) + [] >>= f = [] + return x = [x] + fail s = [] + +instance Read a => Read [a] where + readsPrec p = readList + +instance Show a => Show [a] where + showsPrec p = showList + +-- Tuples ------------------------------------------------------------------- + +-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show) +-- etc.. + +-- Functions ---------------------------------------------------------------- + +instance Show (a -> b) where + showsPrec p f = showString "<>" + +instance Functor ((->) a) where + fmap = (.) + +-- Standard Integral types -------------------------------------------------- + +data Int -- builtin datatype of fixed size integers +data Integer -- builtin datatype of arbitrary size integers + +instance Eq Integer where + (==) x y = primCompareInteger x y == 0 + +instance Ord Integer where + compare x y = case primCompareInteger x y of + -1 -> LT + 0 -> EQ + 1 -> GT + +instance Eq Int where + (==) = primEqInt + (/=) = primNeInt + +instance Ord Int where + (<) = primLtInt + (<=) = primLeInt + (>=) = primGeInt + (>) = primGtInt + +instance Num Int where + (+) = primPlusInt + (-) = primMinusInt + negate = primNegateInt + (*) = primTimesInt + abs = absReal + signum = signumReal + fromInteger = primIntegerToInt + fromInt x = x + +instance Bounded Int where + minBound = primMinInt + maxBound = primMaxInt + +instance Num Integer where + (+) = primPlusInteger + (-) = primMinusInteger + negate = primNegateInteger + (*) = primTimesInteger + abs = absReal + signum = signumReal + fromInteger x = x + fromInt = primIntToInteger + +absReal x | x >= 0 = x + | otherwise = -x + +signumReal x | x == 0 = 0 + | x > 0 = 1 + | otherwise = -1 + +instance Real Int where + toRational x = toInteger x % 1 + +instance Real Integer where + toRational x = x % 1 + +instance Integral Int where + quotRem = primQuotRemInt + toInteger = primIntToInteger + toInt x = x + +instance Integral Integer where + quotRem = primQuotRemInteger + divMod = primDivModInteger + toInteger = id + toInt = primIntegerToInt + +instance Ix Int where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = i - m + | otherwise = error "index: Index out of range" + inRange (m,n) i = m <= i && i <= n + +instance Ix Integer where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = fromInteger (i - m) + | otherwise = error "index: Index out of range" + inRange (m,n) i = m <= i && i <= n + +instance Enum Int where + toEnum = id + fromEnum = id + enumFrom = numericEnumFrom + enumFromTo = numericEnumFromTo + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +instance Enum Integer where + toEnum = primIntToInteger + fromEnum = primIntegerToInt + enumFrom = numericEnumFrom + enumFromTo = numericEnumFromTo + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +numericEnumFrom :: Real a => a -> [a] +numericEnumFromThen :: Real a => a -> a -> [a] +numericEnumFromTo :: Real a => a -> a -> [a] +numericEnumFromThenTo :: Real a => a -> a -> a -> [a] +numericEnumFrom n = n : (numericEnumFrom $! (n+1)) +numericEnumFromThen n m = iterate ((m-n)+) n +numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n) +numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n') + where p | n' > n = (<= m) + | otherwise = (>= m) + +instance Read Int where + readsPrec p = readSigned readDec + +instance Show Int where + showsPrec p n + | n == minBound = showSigned showInt p (toInteger n) + | otherwise = showSigned showInt p n + +instance Read Integer where + readsPrec p = readSigned readDec + +instance Show Integer where + showsPrec = showSigned showInt + +-- Standard Floating types -------------------------------------------------- + +data Float -- builtin datatype of single precision floating point numbers +data Double -- builtin datatype of double precision floating point numbers + +instance Eq Float where + (==) = primEqFloat + (/=) = primNeFloat + +instance Ord Float where + (<) = primLtFloat + (<=) = primLeFloat + (>=) = primGeFloat + (>) = primGtFloat + +instance Num Float where + (+) = primPlusFloat + (-) = primMinusFloat + negate = primNegateFloat + (*) = primTimesFloat + abs = absReal + signum = signumReal + fromInteger = primIntegerToFloat + fromInt = primIntToFloat + + + +instance Eq Double where + (==) = primEqDouble + (/=) = primNeDouble + +instance Ord Double where + (<) = primLtDouble + (<=) = primLeDouble + (>=) = primGeDouble + (>) = primGtDouble + +instance Num Double where + (+) = primPlusDouble + (-) = primMinusDouble + negate = primNegateDouble + (*) = primTimesDouble + abs = absReal + signum = signumReal + fromInteger = primIntegerToDouble + fromInt = primIntToDouble + + + +instance Real Float where + toRational = floatToRational + +instance Real Double where + toRational = doubleToRational + +-- Calls to these functions are optimised when passed as arguments to +-- fromRational. +floatToRational :: Float -> Rational +doubleToRational :: Double -> Rational +floatToRational x = realFloatToRational x +doubleToRational x = realFloatToRational x + +realFloatToRational x = (m%1)*(b%1)^^n + where (m,n) = decodeFloat x + b = floatRadix x + +instance Fractional Float where + (/) = primDivideFloat + fromRational = rationalToRealFloat + fromDouble = primDoubleToFloat + + +instance Fractional Double where + (/) = primDivideDouble + fromRational = rationalToRealFloat + fromDouble x = x + +rationalToRealFloat x = x' + where x' = f e + f e = if e' == e then y else f e' + where y = encodeFloat (round (x * (1%b)^^e)) e + (_,e') = decodeFloat y + (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' + / fromInteger (denominator x)) + b = floatRadix x' + +instance Floating Float where + pi = 3.14159265358979323846 + exp = primExpFloat + log = primLogFloat + sqrt = primSqrtFloat + sin = primSinFloat + cos = primCosFloat + tan = primTanFloat + asin = primAsinFloat + acos = primAcosFloat + atan = primAtanFloat + +instance Floating Double where + pi = 3.14159265358979323846 + exp = primExpDouble + log = primLogDouble + sqrt = primSqrtDouble + sin = primSinDouble + cos = primCosDouble + tan = primTanDouble + asin = primAsinDouble + acos = primAcosDouble + atan = primAtanDouble + +instance RealFrac Float where + properFraction = floatProperFraction + +instance RealFrac Double where + properFraction = floatProperFraction + +floatProperFraction x + | n >= 0 = (fromInteger m * fromInteger b ^ n, 0) + | otherwise = (fromInteger w, encodeFloat r n) + where (m,n) = decodeFloat x + b = floatRadix x + (w,r) = quotRem m (b^(-n)) + +instance RealFloat Float where + floatRadix _ = toInteger primRadixFloat + floatDigits _ = primDigitsFloat + floatRange _ = (primMinExpFloat,primMaxExpFloat) + encodeFloat = primEncodeFloatZ + decodeFloat = primDecodeFloatZ + isNaN = primIsNaNFloat + isInfinite = primIsInfiniteFloat + isDenormalized= primIsDenormalizedFloat + isNegativeZero= primIsNegativeZeroFloat + isIEEE = const primIsIEEEFloat + +instance RealFloat Double where + floatRadix _ = toInteger primRadixDouble + floatDigits _ = primDigitsDouble + floatRange _ = (primMinExpDouble,primMaxExpDouble) + encodeFloat = primEncodeDoubleZ + decodeFloat = primDecodeDoubleZ + isNaN = primIsNaNDouble + isInfinite = primIsInfiniteDouble + isDenormalized= primIsDenormalizedDouble + isNegativeZero= primIsNegativeZeroDouble + isIEEE = const primIsIEEEDouble + +instance Enum Float where + toEnum = primIntToFloat + fromEnum = truncate + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo n m = numericEnumFromTo n (m+1/2) + enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2) + +instance Enum Double where + toEnum = primIntToDouble + fromEnum = truncate + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo n m = numericEnumFromTo n (m+1/2) + enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2) + +instance Read Float where + readsPrec p = readSigned readFloat + +instance Show Float where + showsPrec p = showFloat + --error "should call showFloat" + +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" + +-- Some standard functions -------------------------------------------------- + +fst :: (a,b) -> a +fst (x,_) = x + +snd :: (a,b) -> b +snd (_,y) = y + +curry :: ((a,b) -> c) -> (a -> b -> c) +curry f x y = f (x,y) + +uncurry :: (a -> b -> c) -> ((a,b) -> c) +uncurry f p = f (fst p) (snd p) + +id :: a -> a +id x = x + +const :: a -> b -> a +const k _ = k + +(.) :: (b -> c) -> (a -> b) -> (a -> c) +(f . g) x = f (g x) + +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +($) :: (a -> b) -> a -> b +f $ x = f x + +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x = if p x then x else until p f (f x) + +asTypeOf :: a -> a -> a +asTypeOf = const + +error :: String -> a +error msg = primRaise (ErrorCall msg) + +undefined :: a +undefined | False = undefined + +-- Standard functions on rational numbers {PreludeRatio} -------------------- + +data Integral a => Ratio a = a :% a deriving (Eq) +type Rational = Ratio Integer + +(%) :: Integral a => a -> a -> Ratio a +x % y = reduce (x * signum y) (abs y) + +reduce :: Integral a => a -> a -> Ratio a +reduce x y | y == 0 = error "Ratio.%: zero denominator" + | otherwise = (x `quot` d) :% (y `quot` d) + where d = gcd x y + +numerator, denominator :: Integral a => Ratio a -> a +numerator (x :% y) = x +denominator (x :% y) = y + +instance Integral a => Ord (Ratio a) where + compare (x:%y) (x':%y') = compare (x*y') (x'*y) + +instance Integral a => Num (Ratio a) where + (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') + (x:%y) * (x':%y') = reduce (x*x') (y*y') + negate (x :% y) = negate x :% y + abs (x :% y) = abs x :% y + signum (x :% y) = signum x :% 1 + fromInteger x = fromInteger x :% 1 + fromInt = intToRatio + +-- Hugs optimises code of the form fromRational (intToRatio x) +intToRatio :: Integral a => Int -> Ratio a +intToRatio x = fromInt x :% 1 + +instance Integral a => Real (Ratio a) where + toRational (x:%y) = toInteger x :% toInteger y + +instance Integral a => Fractional (Ratio a) where + (x:%y) / (x':%y') = (x*y') % (y*x') + recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + fromRational (x:%y) = fromInteger x :% fromInteger y + fromDouble = doubleToRatio + +-- Hugs optimises code of the form fromRational (doubleToRatio x) +doubleToRatio :: Integral a => Double -> Ratio a +doubleToRatio x + | n>=0 = (fromInteger m * fromInteger b ^ n) % 1 + | otherwise = fromInteger m % (fromInteger b ^ (-n)) + where (m,n) = decodeFloat x + b = floatRadix x + +instance Integral a => RealFrac (Ratio a) where + properFraction (x:%y) = (fromIntegral q, r:%y) + where (q,r) = quotRem x y + +instance Integral a => Enum (Ratio a) where + toEnum = fromInt + fromEnum = truncate + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + +instance (Read a, Integral a) => Read (Ratio a) where + readsPrec p = readParen (p > 7) + (\r -> [(x%y,u) | (x,s) <- reads r, + ("%",t) <- lex s, + (y,u) <- reads t ]) + +instance Integral a => Show (Ratio a) where + showsPrec p (x:%y) = showParen (p > 7) + (shows x . showString " % " . shows y) + +approxRational :: RealFrac a => a -> a -> Rational +approxRational x eps = simplest (x-eps) (x+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr@(n:%d) = toRational x + (n':%d') = toRational y + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + (n'':%d'') = simplest' d' r' d r + +-- Standard list functions {PreludeList} ------------------------------------ + +head :: [a] -> a +head (x:_) = x + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs + +tail :: [a] -> [a] +tail (_:xs) = xs + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs + +null :: [a] -> Bool +null [] = True +null (_:_) = False + +(++) :: [a] -> [a] -> [a] +[] ++ ys = ys +(x:xs) ++ ys = x : (xs ++ ys) + +map :: (a -> b) -> [a] -> [b] +map f xs = [ f x | x <- xs ] + +filter :: (a -> Bool) -> [a] -> [a] +filter p xs = [ x | x <- xs, p x ] + +concat :: [[a]] -> [a] +concat = foldr (++) [] + +length :: [a] -> Int +length = foldl' (\n _ -> n + 1) 0 + +(!!) :: [b] -> Int -> b +(x:_) !! 0 = x +(_:xs) !! n | n>0 = xs !! (n-1) +(_:_) !! _ = error "Prelude.!!: negative index" +[] !! _ = error "Prelude.!!: index too large" + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z [] = z +foldl f z (x:xs) = foldl f (f z x) xs + +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' f a [] = a +foldl' f a (x:xs) = (foldl' f $! f a x) xs + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs + +foldr :: (a -> b -> b) -> b -> [a] -> b +foldr f z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 f [x] = x +foldr1 f (x:xs) = f x (foldr1 f xs) + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs + +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) + +repeat :: a -> [a] +repeat x = xs where xs = x:xs + +replicate :: Int -> a -> [a] +replicate n x = take n (repeat x) + +cycle :: [a] -> [a] +cycle [] = error "Prelude.cycle: empty list" +cycle xs = xs' where xs'=xs++xs' + +take :: Int -> [a] -> [a] +take 0 _ = [] +take _ [] = [] +take n (x:xs) | n>0 = x : take (n-1) xs +take _ _ = error "Prelude.take: negative argument" + +drop :: Int -> [a] -> [a] +drop 0 xs = xs +drop _ [] = [] +drop n (_:xs) | n>0 = drop (n-1) xs +drop _ _ = error "Prelude.drop: negative argument" + +splitAt :: Int -> [a] -> ([a], [a]) +splitAt 0 xs = ([],xs) +splitAt _ [] = ([],[]) +splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs +splitAt _ _ = error "Prelude.splitAt: negative argument" + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p [] = [] +takeWhile p (x:xs) + | p x = x : takeWhile p xs + | otherwise = [] + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs + +span, break :: (a -> Bool) -> [a] -> ([a],[a]) +span p [] = ([],[]) +span p xs@(x:xs') + | p x = (x:ys, zs) + | otherwise = ([],xs) + where (ys,zs) = span p xs' +break p = span (not . p) + +lines :: String -> [String] +lines "" = [] +lines s = let (l,s') = break ('\n'==) s + in l : case s' of [] -> [] + (_:s'') -> lines s'' + +words :: String -> [String] +words s = case dropWhile isSpace s of + "" -> [] + s' -> w : words s'' + where (w,s'') = break isSpace s' + +unlines :: [String] -> String +unlines = concatMap (\l -> l ++ "\n") + +unwords :: [String] -> String +unwords [] = [] +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws + +reverse :: [a] -> [a] +reverse = foldl (flip (:)) [] + +and, or :: [Bool] -> Bool +and = foldr (&&) True +or = foldr (||) False + +any, all :: (a -> Bool) -> [a] -> Bool +any p = or . map p +all p = and . map p + +elem, notElem :: Eq a => a -> [a] -> Bool +elem = any . (==) +notElem = all . (/=) + +lookup :: Eq a => a -> [(a,b)] -> Maybe b +lookup k [] = Nothing +lookup k ((x,y):xys) + | k==x = Just y + | otherwise = lookup k xys + +sum, product :: Num a => [a] -> a +sum = foldl' (+) 0 +product = foldl' (*) 1 + +maximum, minimum :: Ord a => [a] -> a +maximum = foldl1 max +minimum = foldl1 min + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = concat . map f + +zip :: [a] -> [b] -> [(a,b)] +zip = zipWith (\a b -> (a,b)) + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 = zipWith3 (\a b c -> (a,b,c)) + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z (a:as) (b:bs) = z a b : zipWith z as bs +zipWith _ _ _ = [] + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3 z as bs cs +zipWith3 _ _ _ _ = [] + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], []) + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) + +-- PreludeText ---------------------------------------------------------------- + +reads :: Read a => ReadS a +reads = readsPrec 0 + +shows :: Show a => a -> ShowS +shows = showsPrec 0 + +read :: Read a => String -> a +read s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + [] -> error "Prelude.read: no parse" + _ -> error "Prelude.read: ambiguous parse" + +showChar :: Char -> ShowS +showChar = (:) + +showString :: String -> ShowS +showString = (++) + +showParen :: Bool -> ShowS -> ShowS +showParen b p = if b then showChar '(' . p . showChar ')' else p + +showField :: Show a => String -> a -> ShowS +showField m v = showString m . showChar '=' . shows v + +readParen :: Bool -> ReadS a -> ReadS a +readParen b g = if b then mandatory else optional + where optional r = g r ++ mandatory r + mandatory r = [(x,u) | ("(",s) <- lex r, + (x,t) <- optional s, + (")",u) <- lex t ] + + +readField :: Read a => String -> ReadS a +readField m s0 = [ r | (t, s1) <- lex s0, t == m, + ("=",s2) <- lex s1, + r <- reads s2 ] + +lex :: ReadS String +lex "" = [("","")] +lex (c:s) | isSpace c = lex (dropWhile isSpace s) +lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, + ch /= "'" ] +lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] + where + lexString ('"':s) = [("\"",s)] + lexString s = [(ch++str, u) + | (ch,t) <- lexStrItem s, + (str,u) <- lexString t ] + + lexStrItem ('\\':'&':s) = [("\\&",s)] + lexStrItem ('\\':c:s) | isSpace c + = [("",t) | '\\':t <- [dropWhile isSpace s]] + lexStrItem s = lexLitChar s + +lex (c:s) | isSingle c = [([c],s)] + | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]] + | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] + | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], + (fe,t) <- lexFracExp s ] + | otherwise = [] -- bad character + where + isSingle c = c `elem` ",;()[]{}_`" + isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" + isIdChar c = isAlphaNum c || c `elem` "_'" + + lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, + (e,u) <- lexExp t ] + lexFracExp s = [("",s)] + + lexExp (e:s) | e `elem` "eE" + = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", + (ds,u) <- lexDigits t] ++ + [(e:ds,t) | (ds,t) <- lexDigits s] + lexExp s = [("",s)] + +lexDigits :: ReadS String +lexDigits = nonnull isDigit + +nonnull :: (Char -> Bool) -> ReadS String +nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] + +lexLitChar :: ReadS String +lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] + where + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] + lexEsc s@(d:_) | isDigit d = lexDigits s + lexEsc s@(c:_) | isUpper c + = let table = ('\DEL',"DEL") : asciiTab + in case [(mne,s') | (c, mne) <- table, + ([],s') <- [lexmatch mne s]] + of (pr:_) -> [pr] + [] -> [] + lexEsc _ = [] +lexLitChar (c:s) = [([c],s)] +lexLitChar "" = [] + +isOctDigit c = c >= '0' && c <= '7' +isHexDigit c = isDigit c || c >= 'A' && c <= 'F' + || c >= 'a' && c <= 'f' + +lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a]) +lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys +lexmatch xs ys = (xs,ys) + +asciiTab = zip ['\NUL'..' '] + ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + "SP"] + +readLitChar :: ReadS Char +readLitChar ('\\':s) = readEsc s + where + readEsc ('a':s) = [('\a',s)] + readEsc ('b':s) = [('\b',s)] + readEsc ('f':s) = [('\f',s)] + readEsc ('n':s) = [('\n',s)] + readEsc ('r':s) = [('\r',s)] + readEsc ('t':s) = [('\t',s)] + readEsc ('v':s) = [('\v',s)] + readEsc ('\\':s) = [('\\',s)] + readEsc ('"':s) = [('"',s)] + readEsc ('\'':s) = [('\'',s)] + readEsc ('^':c:s) | c >= '@' && c <= '_' + = [(toEnum (fromEnum c - fromEnum '@'), s)] + readEsc s@(d:_) | isDigit d + = [(toEnum n, t) | (n,t) <- readDec s] + readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s] + readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s] + readEsc s@(c:_) | isUpper c + = let table = ('\DEL',"DEL") : asciiTab + in case [(c,s') | (c, mne) <- table, + ([],s') <- [lexmatch mne s]] + of (pr:_) -> [pr] + [] -> [] + readEsc _ = [] +readLitChar (c:s) = [(c,s)] + +showLitChar :: Char -> ShowS +showLitChar c | c > '\DEL' = showChar '\\' . + protectEsc isDigit (shows (fromEnum c)) +showLitChar '\DEL' = showString "\\DEL" +showLitChar '\\' = showString "\\\\" +showLitChar c | c >= ' ' = showChar c +showLitChar '\a' = showString "\\a" +showLitChar '\b' = showString "\\b" +showLitChar '\f' = showString "\\f" +showLitChar '\n' = showString "\\n" +showLitChar '\r' = showString "\\r" +showLitChar '\t' = showString "\\t" +showLitChar '\v' = showString "\\v" +showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO") +showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c)) + +protectEsc p f = f . cont + where cont s@(c:_) | p c = "\\&" ++ s + cont s = s + +-- Unsigned readers for various bases +readDec, readOct, readHex :: Integral a => ReadS a +readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0') +readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0') +readHex = readInt 16 isHexDigit hex + where hex d = fromEnum d - + (if isDigit d + then fromEnum '0' + else fromEnum (if isUpper d then 'A' else 'a') - 10) + +-- readInt reads a string of digits using an arbitrary base. +-- Leading minus signs must be handled elsewhere. + +readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a +readInt radix isDig digToInt s = + [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r) + | (ds,r) <- nonnull isDig s ] + +-- showInt is used for positive numbers only +showInt :: Integral a => a -> ShowS +showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers" + | otherwise = + let (n',d) = quotRem n 10 + r' = toEnum (fromEnum '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' + +readSigned:: Real a => ReadS a -> ReadS a +readSigned readPos = readParen False read' + where read' r = read'' r ++ + [(-x,t) | ("-",s) <- lex r, + (x,t) <- read'' s] + read'' r = [(n,s) | (str,s) <- lex r, + (n,"") <- readPos str] + +showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS +showSigned showPos p x = if x < 0 then showParen (p > 6) + (showChar '-' . showPos (-x)) + else showPos x + +readFloat :: RealFloat a => ReadS a +readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, + (k,t) <- readExp s] + where readFix r = [(read (ds++ds'), length ds', t) + | (ds, s) <- lexDigits r + , (ds',t) <- lexFrac s ] + + lexFrac ('.':s) = lexDigits s + lexFrac s = [("",s)] + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = [(0,s)] + + readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] + readExp' ('+':s) = readDec s + readExp' s = readDec s + + +-- Hooks for primitives: ----------------------------------------------------- +-- Do not mess with these! + +primCompAux :: Ord a => a -> a -> Ordering -> Ordering +primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT + +primPmInt :: Num a => Int -> a -> Bool +primPmInt n x = fromInt n == x + +primPmInteger :: Num a => Integer -> a -> Bool +primPmInteger n x = fromInteger n == x + +primPmFlt :: Fractional a => Double -> a -> Bool +primPmFlt n x = fromDouble n == x + +-- ToDo: make the message more informative. +primPmFail :: a +primPmFail = error "Pattern Match Failure" +primPmFailBUG :: a +primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++ + "**Please** report to v-julsew@microsoft.com. Thx!\n") + +-- used in desugaring Foreign functions +primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a +primMkIO = ST + +-- The following primitives are only needed if (n+k) patterns are enabled: +primPmNpk :: Integral a => Int -> a -> Maybe a +primPmNpk n x = if n'<=x then Just (x-n') else Nothing + where n' = fromInt n + +primPmSub :: Integral a => Int -> a -> a +primPmSub n x = x - fromInt n + +-- Unpack strings generated by the Hugs code generator. +-- Strings can contain \0 provided they're coded right. +-- +-- ToDo: change this (and Hugs code generator) to use ByteArrays + +primUnpackString :: Addr -> String +primUnpackString a = unpack 0 + where + -- The following decoding is based on evalString in the old machine.c + unpack i + | c == '\0' = [] + | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1) + then '\\' : unpack (i+2) + else '\0' : unpack (i+2) + | otherwise = c : unpack (i+1) + where + c = primIndexCharOffAddr a i + + +-- Monadic I/O: -------------------------------------------------------------- + +type FilePath = String + +--data IOError = ... +--instance Eq IOError ... +--instance Show IOError ... + +data IOError = IOError String +instance Show IOError where + showsPrec _ (IOError s) = showString ("I/O error: " ++ s) + +ioError :: IOError -> IO a +ioError (IOError s) = primRaise (IOExcept s) + +userError :: String -> IOError +userError s = primRaise (ErrorCall s) + +catch :: IO a -> (IOError -> IO a) -> IO a +catch x eh = primCatch x (eh.exception2ioerror) + where + exception2ioerror (IOExcept s) = IOError s + exception2ioerror other = IOError (show other) + +putChar :: Char -> IO () +putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c) + +putStr :: String -> IO () +putStr s = --mapM_ putChar s -- correct, but slow + nh_stdout >>= \h -> + let loop [] = return () + loop (c:cs) = nh_write h (primCharToInt c) >> loop cs + in loop s + +putStrLn :: String -> IO () +putStrLn s = do { putStr s; putChar '\n' } + +print :: Show a => a -> IO () +print = putStrLn . show + +getChar :: IO Char +getChar = unsafeInterleaveIO ( + nh_stdin >>= \h -> + nh_read h >>= \ci -> + return (primIntToChar ci) + ) + +getLine :: IO String +getLine = do c <- getChar + if c=='\n' then return "" + else do cs <- getLine + return (c:cs) + +getContents :: IO String +getContents = nh_stdin >>= \h -> readfromhandle h + +interact :: (String -> String) -> IO () +interact f = getContents >>= (putStr . f) + +readFile :: FilePath -> IO String +readFile fname + = fileopen_sendname fname >>= \ptr -> + nh_open ptr 0 >>= \h -> + nh_free ptr >> + nh_errno >>= \errno -> + if (h == 0 || errno /= 0) + then (ioError.IOError) ("readFile: can't open file " ++ fname) + else readfromhandle h + +writeFile :: FilePath -> String -> IO () +writeFile fname contents + = fileopen_sendname fname >>= \ptr -> + nh_open ptr 1 >>= \h -> + nh_free ptr >> + nh_errno >>= \errno -> + if (h == 0 || errno /= 0) + then (ioError.IOError) ("writeFile: can't create file " ++ fname) + else writetohandle fname h contents + + +appendFile :: FilePath -> String -> IO () +appendFile fname contents + = fileopen_sendname fname >>= \ptr -> + nh_open ptr 2 >>= \h -> + nh_free ptr >> + nh_errno >>= \errno -> + if (h == 0 || errno /= 0) + then (ioError.IOError) ("appendFile: can't open file " ++ fname) + else writetohandle fname h contents + + +-- raises an exception instead of an error +readIO :: Read a => String -> IO a +readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> ioError (userError "PreludeIO.readIO: no parse") + _ -> ioError (userError + "PreludeIO.readIO: ambiguous parse") + +readLn :: Read a => IO a +readLn = do l <- getLine + r <- readIO l + return r + + +-- End of Hugs standard prelude ---------------------------------------------- + +data Exception + = ErrorCall String + | IOExcept String + +instance Show Exception where + showsPrec _ (ErrorCall s) = showString ("error: " ++ s) + showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s) + +data IOResult = IOResult deriving (Show) + +type FILE_STAR = Int + +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_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_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 + in + loop 0 fname + +readfromhandle :: FILE_STAR -> IO String +readfromhandle h + = unsafeInterleaveIO ( + nh_read h >>= \ci -> + if ci == -1 {-EOF-} then return "" else + readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile) + ) + +writetohandle :: String -> FILE_STAR -> String -> IO () +writetohandle fname h [] + = nh_close h >> + nh_errno >>= \errno -> + if errno == 0 + then return () + else error ( "writeFile/appendFile: error closing file " ++ fname) +writetohandle fname h (c:cs) + = nh_write h (primCharToInt c) >> + writetohandle fname h cs + +------------------------------------------------------------------------------ +-- ST, IO -------------------------------------------------------------------- +------------------------------------------------------------------------------ + +newtype ST s a = ST (s -> (a,s)) + +data RealWorld +type IO a = ST RealWorld a + + +--runST :: (forall s. ST s a) -> a +runST :: ST RealWorld a -> a +runST m = fst (unST m theWorld) + where + theWorld :: RealWorld + theWorld = error "runST: entered the RealWorld" + +unST (ST a) = a + +instance Functor (ST s) where + fmap f x = x >>= (return . f) + +instance Monad (ST s) where + m >> k = m >>= \ _ -> k + return x = ST $ \ s -> (x,s) + m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' } + + +-- used when Hugs invokes top level function +primRunIO :: IO () -> () +primRunIO m + = protect (fst (unST m realWorld)) + where + realWorld = error "panic: Hugs entered the real world" + protect :: () -> () + protect comp + = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld)) + +trace :: String -> a -> a +trace s x + = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) + +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO = unsafeInterleaveST + + +------------------------------------------------------------------------------ +-- Addr, ForeignObj, Prim*Array ---------------------------------------------- +------------------------------------------------------------------------------ + +data Addr + +nullAddr = primIntToAddr 0 + +instance Eq Addr where + (==) = primEqAddr + (/=) = primNeAddr + +instance Ord Addr where + (<) = primLtAddr + (<=) = primLeAddr + (>=) = primGeAddr + (>) = primGtAddr + + +data ForeignObj +makeForeignObj :: Addr -> IO ForeignObj +makeForeignObj = primMakeForeignObj + + +data PrimArray a -- immutable arrays with Int indices +data PrimByteArray + +data Ref s a -- mutable variables +data PrimMutableArray s a -- mutable arrays with Int indices +data PrimMutableByteArray s + + +------------------------------------------------------------------------------ +-- hooks to call libHS_cbits ------------------------------------------------- +------------------------------------------------------------------------------ +{- +type FILE_OBJ = ForeignObj -- as passed into functions +type CString = PrimByteArray +type How = Int +type Binary = Int +type OpenFlags = Int +type IOFileAddr = Addr -- as returned from functions +type FD = Int +type OpenStdFlags = Int +type Readable = Int -- really Bool +type Exclusive = Int -- really Bool +type RC = Int -- standard return code +type Bytes = PrimMutableByteArray RealWorld +type Flush = Int -- really Bool + +foreign import stdcall "libHS_cbits.so" "freeStdFileObject" + freeStdFileObject :: ForeignObj -> IO () + +foreign import stdcall "libHS_cbits.so" "freeFileObject" + freeFileObject :: ForeignObj -> IO () + +foreign import stdcall "libHS_cbits.so" "setBuf" + prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () + +foreign import stdcall "libHS_cbits.so" "getBufSize" + prim_getBufSize :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "inputReady" + prim_inputReady :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "fileGetc" + prim_fileGetc :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "fileLookAhead" + prim_fileLookAhead :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "readBlock" + prim_readBlock :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "readLine" + prim_readLine :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "readChar" + prim_readChar :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "writeFileObject" + prim_writeFileObject :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "filePutc" + prim_filePutc :: FILE_OBJ -> Char -> IO RC + +foreign import stdcall "libHS_cbits.so" "getBufStart" + prim_getBufStart :: FILE_OBJ -> Int -> IO Addr + +foreign import stdcall "libHS_cbits.so" "getWriteableBuf" + prim_getWriteableBuf :: FILE_OBJ -> IO Addr + +foreign import stdcall "libHS_cbits.so" "getBufWPtr" + prim_getBufWPtr :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "setBufWPtr" + prim_setBufWPtr :: FILE_OBJ -> Int -> IO () + +foreign import stdcall "libHS_cbits.so" "closeFile" + prim_closeFile :: FILE_OBJ -> Flush -> IO RC + +foreign import stdcall "libHS_cbits.so" "fileEOF" + prim_fileEOF :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "setBuffering" + prim_setBuffering :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "flushFile" + prim_flushFile :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "getBufferMode" + prim_getBufferMode :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "seekFileP" + prim_seekFileP :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "setTerminalEcho" + prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "getTerminalEcho" + prim_getTerminalEcho :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "isTerminalDevice" + prim_isTerminalDevice :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "setConnectedTo" + prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () + +foreign import stdcall "libHS_cbits.so" "ungetChar" + prim_ungetChar :: FILE_OBJ -> Char -> IO RC + +foreign import stdcall "libHS_cbits.so" "readChunk" + prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "writeBuf" + prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "getFileFd" + prim_getFileFd :: FILE_OBJ -> IO FD + +foreign import stdcall "libHS_cbits.so" "fileSize_int64" + prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC + +foreign import stdcall "libHS_cbits.so" "getFilePosn" + prim_getFilePosn :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "setFilePosn" + prim_setFilePosn :: FILE_OBJ -> Int -> IO Int + +foreign import stdcall "libHS_cbits.so" "getConnFileFd" + prim_getConnFileFd :: FILE_OBJ -> IO FD + +foreign import stdcall "libHS_cbits.so" "allocMemory__" + prim_allocMemory__ :: Int -> IO Addr + +foreign import stdcall "libHS_cbits.so" "getLock" + prim_getLock :: FD -> Exclusive -> IO RC + +foreign import stdcall "libHS_cbits.so" "openStdFile" + prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr + +foreign import stdcall "libHS_cbits.so" "openFile" + prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr + +foreign import stdcall "libHS_cbits.so" "freeFileObject" + prim_freeFileObject :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "freeStdFileObject" + prim_freeStdFileObject :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" + const_BUFSIZ :: Int + +foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" + prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" + prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" + prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" + prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "getErrStr__" + prim_getErrStr__ :: IO Addr + +foreign import stdcall "libHS_cbits.so" "getErrNo__" + prim_getErrNo__ :: IO Int + +foreign import stdcall "libHS_cbits.so" "getErrType__" + prim_getErrType__ :: IO Int + +--foreign import stdcall "libHS_cbits.so" "seekFile_int64" +-- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC +-} + +-- showFloat ------------------------------------------------------------------ + +showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFloat :: (RealFloat a) => a -> ShowS + +showEFloat d x = showString (formatRealFloat FFExponent d x) +showFFloat d x = showString (formatRealFloat FFFixed d x) +showGFloat d x = showString (formatRealFloat FFGeneric d x) +showFloat = showGFloat Nothing + +-- These are the format types. This type is not exported. + +data FFFormat = FFExponent | FFFixed | FFGeneric + +formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String +formatRealFloat fmt decs x = s + where base = 10 + s = if isNaN x then + "NaN" + else if isInfinite x then + if x < 0 then "-Infinity" else "Infinity" + else if x < 0 || isNegativeZero x then + '-' : doFmt fmt (floatToDigits (toInteger base) (-x)) + else + doFmt fmt (floatToDigits (toInteger base) x) + doFmt fmt (is, e) = + let ds = map intToDigit is + in case fmt of + FFGeneric -> + doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) + (is, e) + FFExponent -> + case decs of + Nothing -> + case ds of + ['0'] -> "0.0e0" + [d] -> d : ".0e" ++ show (e-1) + d:ds -> d : '.' : ds ++ 'e':show (e-1) + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0':'.':take dec' (repeat '0') ++ "e0" + _ -> + let (ei, is') = roundTo base (dec'+1) is + d:ds = map intToDigit + (if ei > 0 then init is' else is') + in d:'.':ds ++ "e" ++ show (e-1+ei) + FFFixed -> + case decs of + Nothing -> + let f 0 s ds = mk0 s ++ "." ++ mk0 ds + f n s "" = f (n-1) (s++"0") "" + f n s (d:ds) = f (n-1) (s++[d]) ds + mk0 "" = "0" + mk0 s = s + in f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let (ei, is') = roundTo base (dec' + e) is + (ls, rs) = splitAt (e+ei) (map intToDigit is') + in (if null ls then "0" else ls) ++ + (if null rs then "" else '.' : rs) + else + let (ei, is') = roundTo base dec' + (replicate (-e) 0 ++ is) + d : ds = map intToDigit + (if ei > 0 then is' else 0:is') + in d : '.' : ds + +roundTo :: Int -> Int -> [Int] -> (Int, [Int]) +roundTo base d is = case f d is of + (0, is) -> (0, is) + (1, is) -> (1, 1 : is) + where b2 = base `div` 2 + f n [] = (0, replicate n 0) + f 0 (i:_) = (if i >= b2 then 1 else 0, []) + f d (i:is) = + let (c, ds) = f (d-1) is + i' = c + i + in if i' == base then (1, 0:ds) else (0, i':ds) + +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R. K. Dybvig, in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- This function returns a list of digits (Ints in [0..base-1]) and an +-- exponent. + +floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) + +floatToDigits _ 0 = ([0], 0) +floatToDigits base x = + let (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = let n = minExp - e0 + in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + + (r, s, mUp, mDn) = + if e >= 0 then + let be = b^e in + if f == b^(p-1) then + (f*be*b*2, 2*b, be*b, b) + else + (f*be*2, 2, be, be) + else + if e > minExp && f == b^(p-1) then + (f*b*2, b^(-e+1)*2, b, 1) + else + (f*2, b^(-e)*2, 1, 1) + k = + let k0 = + + 0 + + fixup n = + if n >= 0 then + if r + mUp <= expt base n * s then n else fixup (n+1) + else + if expt base (-n) * (r + mUp) <= s then n + else fixup (n+1) + in fixup k0 + + gen ds rn sN mUpN mDnN = + let (dn, rn') = (rn * base) `divMod` sN + mUpN' = mUpN * base + mDnN' = mDnN * base + in case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + rds = + if k >= 0 then + gen [] r (s * expt base k) mUp mDn + else + let bk = expt base (-k) + 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 diff --git a/ghc/interpreter/lib/Ratio.hs b/ghc/interpreter/lib/Ratio.hs new file mode 100644 index 0000000..46aeebe --- /dev/null +++ b/ghc/interpreter/lib/Ratio.hs @@ -0,0 +1,13 @@ +----------------------------------------------------------------------------- +-- Standard Library: Ratio and Rational types and operations +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +module Ratio ( + Ratio, Rational, (%), numerator, denominator, approxRational ) where + +-- This module is empty; Rational is currently defined in the prelude, +-- but should eventually be moved to this library file instead. + +----------------------------------------------------------------------------- diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 97dc222..c3595c0 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: link.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/03/01 14:46:47 $ + * $Revision: 1.6 $ + * $Date: 1999/03/09 14:51:08 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -122,6 +122,7 @@ Name nameUndefined =BOGUS(62); /* generic undefined value Name namePmSub =BOGUS(63); #endif Name namePMFail =BOGUS(64); +Name namePMFailBUG = BOGUS(666); Name nameEqChar =BOGUS(65); Name nameEqInt =BOGUS(66); #if !OVERLOADED_CONSTANTS @@ -139,8 +140,6 @@ Name nameUnpackString =BOGUS(76); Name nameError =BOGUS(77); Name nameInd =BOGUS(78); -Name nameForce =BOGUS(79); - Name nameAnd =BOGUS(80); Name nameConCmp =BOGUS(82); Name nameCompAux =BOGUS(83); @@ -161,6 +160,11 @@ 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); @@ -227,6 +231,8 @@ 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 @@ -254,6 +260,7 @@ static Tycon linkTycon ( String s ); static Tycon linkClass ( String s ); static Name linkName ( String s ); static Void mkTypes ( void ); +static Name predefinePrim ( String s ); static Tycon linkTycon( String s ) @@ -286,12 +293,17 @@ static Name linkName( String s ) EEND; } -/* ToDo: kill this! */ -static Name predefinePrim ( String s ); -static Name predefinePrim ( String s ) +static Name predefinePrim ( String s ) { - Name nm = newName(findText(s),NIL); - name(nm).defn=PREDEFINED; + Name nm; + Text t = findText(s); + nm = findName(t); + if (nonNull(nm)) { + //fprintf(stderr, "predefinePrim: %s already exists\n", s ); + } else { + nm = newName(t,NIL); + name(nm).defn=PREDEFINED; + } return nm; } @@ -300,7 +312,6 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ if (!initialised) { Int i; initialised = TRUE; - ////setCurrModule(modulePreludeHugs); setCurrModule(modulePrelude); QQ(typeChar ) = linkTycon("Char"); @@ -414,7 +425,6 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ QQ(nameMkThreadId) = addPrimCfun(findTextREP("ThreadId#"),1,0,0); QQ(nameMkMVar ) = addPrimCfun(findTextREP("MVar#"),1,0,0); #endif -#if 1 /* The following primitives are referred to in derived instances and * hence require types; the following types are a little more general * than we might like, but they are the closest we can get without a @@ -437,7 +447,13 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ name(nameEnFrTo).type = name(nameEnFrTh).type = mkPolyType(starToStar,fn(aVar,fn(aVar,listof))); -#endif + + name(namePrimSeq).type + = primType(MONAD_Id, "ab", "b"); + name(namePrimCatch).type + = 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 @@ -517,6 +533,7 @@ Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ QQ(nameMult ) = linkName("*"); QQ(nameRangeSize ) = linkName("rangeSize"); QQ(nameInRange ) = linkName("inRange"); + QQ(nameMinus ) = linkName("-"); /* These come before calls to implementPrim */ for(i=0; i mkOffset(1) */ extern Type listof; /* [ mkOffset(0) ] */ diff --git a/ghc/interpreter/optimise.c b/ghc/interpreter/optimise.c index 170a0c6..a891389 100644 --- a/ghc/interpreter/optimise.c +++ b/ghc/interpreter/optimise.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: optimise.c,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:33 $ + * $Revision: 1.4 $ + * $Date: 1999/03/09 14:51:09 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -45,9 +45,11 @@ static StgAtom optimiseAtom(StgAtom a) static StgVar optimiseVar(StgVar v) { StgRhs rhs = stgVarBody(v); - /* short circuit: let x = y in ...x... --> let x = y ...y... */ +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"); /* find last variable in chain */ rhs = stgVarBody(v1); @@ -75,7 +77,8 @@ static StgVar optimiseVar(StgVar v) void optimiseBind( StgVar v ) { - StgRhs rhs = stgVarBody(v); + StgRhs rhs; + rhs = stgVarBody(v); switch (whatIs(rhs)) { case STGCON: mapOver(optimiseAtom,stgConArgs(rhs)); @@ -122,7 +125,9 @@ static StgExpr optimiseExpr( StgExpr e ) * 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); } } @@ -210,4 +215,22 @@ static StgExpr optimiseExpr( StgExpr e ) return e; } + +void optimiseTopBind( StgVar v ) +{ +if (lastModule() != modulePrelude) { +fflush(stdout); fflush(stderr); +fprintf ( stderr, "------------------------------\n" ); +fflush(stderr); +printStg ( stderr, v ); +fprintf(stderr, "\n" ); +} +optimiseBind ( v ); +if (lastModule() != modulePrelude) { +printStg ( stderr,v ); +fprintf(stderr, "\n\n" ); +fflush(stderr); +} +} + /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 69f1a28..c54fb2c 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -11,8 +11,8 @@ * in the distribution for details. * * $RCSfile: parser.y,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:34 $ + * $Revision: 1.4 $ + * $Date: 1999/03/09 14:51:09 $ * ------------------------------------------------------------------------*/ %{ @@ -1088,7 +1088,7 @@ Cell c; { /* T a1 ... a */ ERRMSG(row) "Illegal left hand side in datatype definition" EEND; } - assert(0); return 0; /* NOTREACHED */ + return 0; /* NOTREACHED */ } #if !TREX diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index afc4696..fbf76b5 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: static.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:51 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:10 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -674,7 +674,7 @@ Cell e; { EEND; } } - assert(0); return 0; /* NOTREACHED */ + return 0; /* NOTREACHED */ } static List local checkExports(exports) @@ -1543,7 +1543,7 @@ Class c; { /* and other parts of class struct.*/ List ns = NIL; /* List of names */ Int mno; /* Member function number */ -//printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) ); + //printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) ); for (mno=0; mno= NUM_TYCON) { ERRMSG(0) "Type constructor storage space exhausted" EEND; @@ -275,22 +281,26 @@ Text t; { tycon(tyconHw).mod = currentModule; module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); #endif + tycon(tyconHw).nextTyconHash = tyconHash[h]; + tyconHash[h] = tyconHw; + return tyconHw++; } -Tycon findTycon ( Text t ) -{ - int n; - for (n = TYCMIN; n < tyconHw; n++) - if (tycon(n).text == t) return n; - return NIL; +Tycon findTycon(t) /* locate Tycon in tycon table */ +Text t; { + Tycon tc = tyconHash[tHash(t)]; + + while (nonNull(tc) && tycon(tc).text!=t) + tc = tycon(tc).nextTyconHash; + return tc; } Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */ Tycon tc; { Tycon oldtc = findTycon(tycon(tc).text); if (isNull(oldtc)) { - // hashTycon(tc); + hashTycon(tc); #if !IGNORE_MODULES module(currentModule).tycons=cons(tc,module(currentModule).tycons); #endif @@ -299,6 +309,14 @@ Tycon tc; { return oldtc; } +static Void local hashTycon(tc) /* Insert Tycon into hash table */ +Tycon tc; { + Text t = tycon(tc).text; + Int h = tHash(t); + tycon(tc).nextTyconHash = tyconHash[h]; + tyconHash[h] = tc; +} + Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */ Cell id; { if (!isPair(id)) internal("findQualTycon"); @@ -324,7 +342,7 @@ Cell id; { } default : internal("findQualTycon2"); } - assert(0); return 0; /* NOTREACHED */ + return 0; /* NOTREACHED */ } Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */ @@ -396,8 +414,7 @@ struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */ Name newName(t,parent) /* Add new name to name table */ Text t; Cell parent; { - //Int h = nHash(t); - + Int h = nHash(t); if (nameHw-NAMEMIN >= NUM_NAME) { ERRMSG(0) "Name storage space exhausted" EEND; @@ -414,24 +431,26 @@ Cell parent; { 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 findName ( Text t ) -{ - int n; - for (n = NAMEMIN; n < nameHw; n++) - if (name(n).text == t) return n; - return NIL; -} - +Name findName(t) /* Locate name in name table */ +Text t; { + Name n = nameHash[nHash(t)]; + while (nonNull(n) && name(n).text!=t) + n = name(n).nextNameHash; + return n; +} Name addName(nm) /* Insert Name in name table - if */ Name nm; { /* no clash is caused */ Name oldnm = findName(name(nm).text); if (isNull(oldnm)) { - // hashName(nm); + hashName(nm); #if !IGNORE_MODULES module(currentModule).names=cons(nm,module(currentModule).names); #endif @@ -440,6 +459,14 @@ Name nm; { /* no clash is caused */ return oldnm; } +static Void local hashName(nm) /* Insert Name into hash table */ +Name nm; { + Text t = name(nm).text; + Int h = nHash(t); + name(nm).nextNameHash = nameHash[h]; + nameHash[h] = nm; +} + Name findQualName(id) /* Locate (possibly qualified) name*/ Cell id; { /* in name table */ if (!isPair(id)) @@ -458,13 +485,6 @@ Cell id; { /* in name table */ Module m = findQualifier(qmodOf(id)); List es = NIL; if (isNull(m)) return NIL; - if (m==currentModule) { - /* The Haskell report (rightly) forbids this. - * We added it to let the Prelude refer to itself - * without having to import itself. - */ - return findName(t); - } for(es=module(m).exports; nonNull(es); es=tl(es)) { Cell e = hd(es); if (isName(e) && name(e).text==t) @@ -478,7 +498,8 @@ Cell id; { /* in name table */ else if (isClass(c)) subentities = cclass(c).members; for(; nonNull(subentities); subentities=tl(subentities)) { - assert(isName(hd(subentities))); + if (!isName(hd(subentities))) + internal("findQualName3"); if (name(hd(subentities)).text == t) return hd(subentities); } @@ -489,7 +510,7 @@ Cell id; { /* in name table */ } default : internal("findQualName2"); } - assert(0); return 0; /* NOTREACHED */ + return 0; /* NOTREACHED */ } /* -------------------------------------------------------------------------- @@ -743,7 +764,6 @@ Inst newInst() { /* Add new instance to table */ inst(instHw).specifics = NIL; inst(instHw).implements = NIL; inst(instHw).builder = NIL; - /* from STG */ inst(instHw).mod = currentModule; return instHw++; } @@ -905,15 +925,6 @@ Cell c; { static local Module findQualifier(t) /* locate Module in import list */ Text t; { Module ms; - ////if (t==module(modulePreludeHugs).text) { - if (t==module(modulePrelude).text) { - /* The Haskell report (rightly) forbids this. - * We added it to let the Prelude refer to itself - * without having to import itself. - */ - ////return modulePreludeHugs; - return modulePrelude; - } for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) { if (textOf(fst(hd(ms)))==t) return snd(hd(ms)); @@ -927,17 +938,15 @@ Text t; { Void setCurrModule(m) /* set lookup tables for current module */ Module m; { - //Int i; + Int i; if (m!=currentModule) { currentModule = m; /* This is the only assignment to currentModule */ -#if 0 for (i=0; i= scripts[sno].moduleHw; --i) { if (module(i).objectFile) { printf("[bogus] closing objectFile for module %d\n",i); @@ -1112,7 +1120,7 @@ Script sno; { /* to reading script sno */ } } moduleHw = scripts[sno].moduleHw; - +#endif for (i=0; i 0; i--) { @@ -475,7 +475,6 @@ static Void ppExp( Name n, Int arity, Cell e ) printExp(stdout,e); printf("\n"); } -#endif } #endif @@ -485,7 +484,13 @@ Void stgDefn( Name n, Int arity, Cell e ) List vs = NIL; List sc = NIL; Int i; - // ppExp(n,arity,e); +#if 0 + if (lastModule() != modulePrelude) { + fprintf(stderr, "\n===========================================\n" ); + ppExp ( n,arity,e); + printf("\n\n"); fflush(stdout); + } +#endif for (i = 1; i <= arity; ++i) { Cell nv = mkStgVar(NIL,NIL); vs = cons(nv,vs); @@ -493,40 +498,42 @@ Void stgDefn( Name n, Int arity, Cell e ) } stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail)); - //ppStg(name(n).stgVar); - //printStg(stdout, name(n).stgVar); -} - -static StgExpr forceArgs( List is, List args, StgExpr e ); - -/* force the args numbered in is */ -static StgExpr forceArgs( List is, List args, StgExpr e ) -{ - for(; nonNull(is); is=tl(is)) { - e = mkSeq(nth(intOf(hd(is))-1,args),e); +#if 0 + if (lastModule() != modulePrelude) { + ppStg(name(n).stgVar); + fprintf(stderr, "\n\n"); } - return e; + //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; - //printf ( "implementCfun %s\n", textToStr(name(c).text) ); - if (name(c).arity > 0) { - List args = makeArgs(a); - StgVar tv = mkStgVar(mkStgCon(c,args),NIL); - StgExpr e1 = mkStgLet(singleton(tv),tv); - StgExpr e2 = forceArgs(scs,args,e1); - StgVar v = mkStgVar(mkStgLambda(args,e2),NIL); + //fprintf ( stderr,"implementCfun %s\n", textToStr(name(c).text) ); + if (a > 0) { + StgVar vcurr, e1, v, vsi; + List args = makeArgs(a); + StgVar v0 = mkStgVar(mkStgCon(c,args),NIL); + List binds = singleton(v0); + + vcurr = v0; + for (; nonNull(scs); scs=tl(scs)) { + vsi = nth(intOf(hd(scs))-1,args); + vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL); + binds = cons(vcurr,binds); + } + binds = rev(binds); + e1 = mkStgLet(binds,vcurr); + v = mkStgVar(mkStgLambda(args,e1),NIL); name(c).stgVar = v; } else { StgVar v = mkStgVar(mkStgCon(c,NIL),NIL); name(c).stgVar = v; } - /* hack to make it print out */ stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); + //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); } /* -------------------------------------------------------------------------- diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index a50db82..1da4c19 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: type.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:57 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:16 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -2251,11 +2251,11 @@ Void typeCheckDefns() { /* Type check top level bindings */ static Void local typeDefnGroup(bs) /* type check group of value defns */ List bs; { /* (one top level scc) */ List as; -// printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n"); -//{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){ -// print(hd(qq),4); -// printf("\n"); -//}} + // printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n"); + //{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){ + // print(hd(qq),4); + // printf("\n"); + //}} emptySubstitution(); hd(defnBounds) = NIL; diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs new file mode 100644 index 0000000..a034776 --- /dev/null +++ b/ghc/lib/hugs/Prelude.hs @@ -0,0 +1,2093 @@ +{---------------------------------------------------------------------------- +__ __ __ __ ____ ___ _______________________________________________ +|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system +||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999 +||---|| ___|| World Wide Web: http://haskell.org/hugs +|| || Report bugs to: hugs-bugs@haskell.org +|| || Version: January 1999 _______________________________________________ + + This is the Hugs 98 Standard Prelude, based very closely on the Standard + Prelude for Haskell 98. + + WARNING: This file is an integral part of the Hugs source code. Changes to + the definitions in this file without corresponding modifications in other + parts of the program may cause the interpreter to fail unexpectedly. Under + normal circumstances, you should not attempt to modify this file in any way! + +----------------------------------------------------------------------------- + Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell + Group 1994-99, and is distributed as Open Source software under the + Artistic License; see the file "Artistic" that is included in the + distribution for details. +----------------------------------------------------------------------------} + +module Prelude ( +-- module PreludeList, + map, (++), concat, filter, + head, last, tail, init, null, length, (!!), + foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, + iterate, repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, + lines, words, unlines, unwords, reverse, and, or, + any, all, elem, notElem, lookup, + sum, product, maximum, minimum, concatMap, + zip, zip3, zipWith, zipWith3, unzip, unzip3, +-- module PreludeText, + ReadS, ShowS, + Read(readsPrec, readList), + Show(show, showsPrec, showList), + reads, shows, read, lex, + showChar, showString, readParen, showParen, +-- module PreludeIO, + FilePath, IOError, ioError, userError, catch, + putChar, putStr, putStrLn, print, + getChar, getLine, getContents, interact, + readFile, writeFile, appendFile, readIO, readLn, +-- module Ix, + Ix(range, index, inRange, rangeSize), +-- module Char, + isAscii, isControl, isPrint, isSpace, isUpper, isLower, + isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, + digitToInt, intToDigit, + toUpper, toLower, + ord, chr, + readLitChar, showLitChar, lexLitChar, +-- module Numeric + showSigned, showInt, + readSigned, readInt, + readDec, readOct, readHex, readSigned, + readFloat, lexDigits, +-- module Ratio, + Ratio, Rational, (%), numerator, denominator, approxRational, +-- Non-standard exports + IO(..), IOResult(..), Addr, + + Bool(False, True), + Maybe(Nothing, Just), + Either(Left, Right), + Ordering(LT, EQ, GT), + Char, String, Int, Integer, Float, Double, IO, +-- List type: []((:), []) + (:), +-- Tuple types: (,), (,,), etc. +-- Trivial type: () +-- Functions: (->) + Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX + Eq((==), (/=)), + Ord(compare, (<), (<=), (>=), (>), max, min), + Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen, + enumFromTo, enumFromThenTo), + Bounded(minBound, maxBound), +-- Num((+), (-), (*), negate, abs, signum, fromInteger), + Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt), + Real(toRational), +-- Integral(quot, rem, div, mod, quotRem, divMod, toInteger), + Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt), +-- Fractional((/), recip, fromRational), + Fractional((/), recip, fromRational, fromDouble), + Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, + asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, + encodeFloat, exponent, significand, scaleFloat, isNaN, + isInfinite, isDenormalized, isIEEE, isNegativeZero), + Monad((>>=), (>>), return, fail), + Functor(fmap), + mapM, mapM_, accumulate, sequence, (=<<), + maybe, either, + (&&), (||), not, otherwise, + subtract, even, odd, gcd, lcm, (^), (^^), + fromIntegral, realToFrac, atan2, + fst, snd, curry, uncurry, id, const, (.), flip, ($), until, + asTypeOf, error, undefined, + seq, ($!) + + ,primCompAux + ) where + +-- Standard value bindings {Prelude} ---------------------------------------- + +infixr 9 . +infixl 9 !! +infixr 8 ^, ^^, ** +infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, % +infixl 6 +, - +--infixr 5 : -- this fixity declaration is hard-wired into Hugs +infixr 5 ++ +infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem` +infixr 3 && +infixr 2 || +infixl 1 >>, >>= +infixr 1 =<< +infixr 0 $, $!, `seq` + +-- Equality and Ordered classes --------------------------------------------- + +class Eq a where + (==), (/=) :: a -> a -> Bool + + -- Minimal complete definition: (==) or (/=) + x == y = not (x/=y) + x /= y = not (x==y) + +class (Eq a) => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>=), (>) :: a -> a -> Bool + max, min :: a -> a -> a + + -- Minimal complete definition: (<=) or compare + -- using compare can be more efficient for complex types + compare x y | x==y = EQ + | x<=y = LT + | otherwise = GT + + x <= y = compare x y /= GT + x < y = compare x y == LT + x >= y = compare x y /= LT + x > y = compare x y == GT + + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + +class Bounded a where + minBound, maxBound :: a + -- Minimal complete definition: All + +-- Numeric classes ---------------------------------------------------------- + +class (Eq a, Show a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + fromInt :: Int -> a + + -- Minimal complete definition: All, except negate or (-) + x - y = x + negate y + fromInt = fromIntegral + negate x = 0 - x + +class (Num a, Ord a) => Real a where + toRational :: a -> Rational + +class (Real a, Enum a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + even, odd :: a -> Bool + toInteger :: a -> Integer + toInt :: a -> Int + + -- Minimal complete definition: quotRem and toInteger + n `quot` d = q where (q,r) = quotRem n d + n `rem` d = r where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + divMod n d = if signum r == - signum d then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + even n = n `rem` 2 == 0 + odd = not . even + toInt = toInt . toInteger + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + fromDouble :: Double -> a + + -- Minimal complete definition: fromRational and ((/) or recip) + recip x = 1 / x + fromDouble = fromRational . toRational + x / y = x * recip y + + +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh, + -- asinh, acosh, atanh + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + tanh x = sinh x / cosh x + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + -- Minimal complete definition: properFraction + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE + :: a -> Bool + atan2 :: a -> a -> a + + -- Minimal complete definition: All, except exponent, signficand, + -- scaleFloat, atan2 + exponent x = if m==0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + significand x = encodeFloat m (- floatDigits x) + where (m,_) = decodeFloat x + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x + atan2 y x + | x>0 = atan (y/x) + | x==0 && y>0 = pi/2 + | x<0 && y>0 = pi + atan (y/x) + | (x<=0 && y<0) || + (x<0 && isNegativeZero y) || + (isNegativeZero x && isNegativeZero y) + = - atan2 (-y) x + | y==0 && (x<0 || isNegativeZero x) + = pi -- must be after the previous test on zero y + | x==0 && y==0 = y -- must be after the other double zero tests + | otherwise = x + y -- x or y is a NaN, return a NaN (via +) + +-- Numeric functions -------------------------------------------------------- + +subtract :: Num a => a -> a -> a +subtract = flip (-) + +gcd :: Integral a => a -> a -> a +gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) + +lcm :: (Integral a) => a -> a -> a +lcm _ 0 = 0 +lcm 0 _ = 0 +lcm x y = abs ((x `quot` gcd x y) * y) + +(^) :: (Num a, Integral b) => a -> b -> a +x ^ 0 = 1 +x ^ n | n > 0 = f x (n-1) x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n`quot`2) + | otherwise = f x (n-1) (x*y) +_ ^ _ = error "Prelude.^: negative exponent" + +(^^) :: (Fractional a, Integral b) => a -> b -> a +x ^^ n = if n >= 0 then x ^ n else recip (x^(-n)) + +fromIntegral :: (Integral a, Num b) => a -> b +fromIntegral = fromInteger . toInteger + +realToFrac :: (Real a, Fractional b) => a -> b +realToFrac = fromRational . toRational + +-- Index and Enumeration classes -------------------------------------------- + +class (Ord a) => Ix a where + range :: (a,a) -> [a] + index :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + rangeSize :: (a,a) -> Int + + rangeSize r@(l,u) + | l > u = 0 + | otherwise = index r u + 1 + +class Enum a where + succ, pred :: a -> a + toEnum :: Int -> a + fromEnum :: a -> Int + enumFrom :: a -> [a] -- [n..] + enumFromThen :: a -> a -> [a] -- [n,m..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + -- Minimal complete definition: toEnum, fromEnum + succ = toEnum . (1+) . fromEnum + pred = toEnum . subtract 1 . fromEnum + enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ] + enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ] + +-- Read and Show classes ------------------------------------------------------ + +type ReadS a = String -> [(a,String)] +type ShowS = String -> String + +class Read a where + readsPrec :: Int -> ReadS a + readList :: ReadS [a] + + -- Minimal complete definition: readsPrec + readList = readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s ]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- reads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- reads t, + (xs,v) <- readl' u] + +class Show a where + show :: a -> String + showsPrec :: Int -> a -> ShowS + showList :: [a] -> ShowS + + -- Minimal complete definition: show or showsPrec + show x = showsPrec 0 x "" + showsPrec _ x s = show x ++ s + showList [] = showString "[]" + showList (x:xs) = showChar '[' . shows x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showChar ',' . shows x . showl xs + +-- Monad classes ------------------------------------------------------------ + +class Functor f where + fmap :: (a -> b) -> (f a -> f b) + +class Monad m where + return :: a -> m a + (>>=) :: m a -> (a -> m b) -> m b + (>>) :: m a -> m b -> m b + fail :: String -> m a + + -- Minimal complete definition: (>>=), return + p >> q = p >>= \ _ -> q + fail s = error s + +accumulate :: Monad m => [m a] -> m [a] +accumulate [] = return [] +accumulate (c:cs) = do x <- c + xs <- accumulate cs + return (x:xs) + +sequence :: Monad m => [m a] -> m () +sequence = foldr (>>) (return ()) + +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +mapM f = accumulate . map f + +mapM_ :: Monad m => (a -> m b) -> [a] -> m () +mapM_ f = sequence . map f + +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f + +-- Evaluation and strictness ------------------------------------------------ + +seq :: a -> b -> b +seq x y = --case primForce x of () -> y + primSeq x y + +($!) :: (a -> b) -> a -> b +f $! x = x `seq` f x + +-- Trivial type ------------------------------------------------------------- + +-- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded) + +instance Eq () where + () == () = True + +instance Ord () where + compare () () = EQ + +instance Ix () where + range ((),()) = [()] + index ((),()) () = 0 + inRange ((),()) () = True + +instance Enum () where + toEnum 0 = () + fromEnum () = 0 + enumFrom () = [()] + enumFromThen () () = [()] + +instance Read () where + readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ]) + +instance Show () where + showsPrec p () = showString "()" + +instance Bounded () where + minBound = () + maxBound = () + +-- Boolean type ------------------------------------------------------------- + +data Bool = False | True + deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded) + +(&&), (||) :: Bool -> Bool -> Bool +False && x = False +True && x = x +False || x = x +True || x = True + +not :: Bool -> Bool +not True = False +not False = True + +otherwise :: Bool +otherwise = True + +-- Character type ----------------------------------------------------------- + +data Char -- builtin datatype of ISO Latin characters +type String = [Char] -- strings are lists of characters + +instance Eq Char where (==) = primEqChar +instance Ord Char where (<=) = primLeChar + +instance Enum Char where + toEnum = primIntToChar + fromEnum = primCharToInt + enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)] + enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)] + where lastChar = if d < c then minBound else maxBound + +instance Ix Char where + range (c,c') = [c..c'] + index b@(c,c') ci + | inRange b ci = fromEnum ci - fromEnum c + | otherwise = error "Ix.index: Index out of range." + inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c' + where i = fromEnum ci + +instance Read Char where + readsPrec p = readParen False + (\r -> [(c,t) | ('\'':s,t) <- lex r, + (c,"\'") <- readLitChar s ]) + readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, + (l,_) <- readl s ]) + where readl ('"':s) = [("",s)] + readl ('\\':'&':s) = readl s + readl s = [(c:cs,u) | (c ,t) <- readLitChar s, + (cs,u) <- readl t ] +instance Show Char where + showsPrec p '\'' = showString "'\\''" + showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' + + showList cs = showChar '"' . showl cs + where showl "" = showChar '"' + showl ('"':cs) = showString "\\\"" . showl cs + showl (c:cs) = showLitChar c . showl cs + +instance Bounded Char where + minBound = '\0' + maxBound = '\255' + +isAscii, isControl, isPrint, isSpace :: Char -> Bool +isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool + +isAscii c = fromEnum c < 128 +isControl c = c < ' ' || c == '\DEL' +isPrint c = c >= ' ' && c <= '~' +isSpace c = c == ' ' || c == '\t' || c == '\n' || + c == '\r' || c == '\f' || c == '\v' +isUpper c = c >= 'A' && c <= 'Z' +isLower c = c >= 'a' && c <= 'z' +isAlpha c = isUpper c || isLower c +isDigit c = c >= '0' && c <= '9' +isAlphaNum c = isAlpha c || isDigit c + +-- Digit conversion operations +digitToInt :: Char -> Int +digitToInt c + | isDigit c = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10 + | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10 + | otherwise = error "Char.digitToInt: not a digit" + +intToDigit :: Int -> Char +intToDigit i + | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i) + | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10) + | otherwise = error "Char.intToDigit: not a digit" + +toUpper, toLower :: Char -> Char +toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') + | otherwise = c + +toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a') + | otherwise = c + +ord :: Char -> Int +ord = fromEnum + +chr :: Int -> Char +chr = toEnum + +-- Maybe type --------------------------------------------------------------- + +data Maybe a = Nothing | Just a + deriving (Eq, Ord, Read, Show) + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n f Nothing = n +maybe n f (Just x) = f x + +instance Functor Maybe where + fmap f Nothing = Nothing + fmap f (Just x) = Just (f x) + +instance Monad Maybe where + Just x >>= k = k x + Nothing >>= k = Nothing + return = Just + fail s = Nothing + +-- Either type -------------------------------------------------------------- + +data Either a b = Left a | Right b + deriving (Eq, Ord, Read, Show) + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either l r (Left x) = l x +either l r (Right y) = r y + +-- Ordering type ------------------------------------------------------------ + +data Ordering = LT | EQ | GT + deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded) + +-- Lists -------------------------------------------------------------------- + +--data [a] = [] | a : [a] deriving (Eq, Ord) + +instance Eq a => Eq [a] where + [] == [] = True + (x:xs) == (y:ys) = x==y && xs==ys + _ == _ = False + +instance Ord a => Ord [a] where + compare [] (_:_) = LT + compare [] [] = EQ + compare (_:_) [] = GT + compare (x:xs) (y:ys) = primCompAux x y (compare xs ys) + +instance Functor [] where + fmap = map + +instance Monad [ ] where + (x:xs) >>= f = f x ++ (xs >>= f) + [] >>= f = [] + return x = [x] + fail s = [] + +instance Read a => Read [a] where + readsPrec p = readList + +instance Show a => Show [a] where + showsPrec p = showList + +-- Tuples ------------------------------------------------------------------- + +-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show) +-- etc.. + +-- Functions ---------------------------------------------------------------- + +instance Show (a -> b) where + showsPrec p f = showString "<>" + +instance Functor ((->) a) where + fmap = (.) + +-- Standard Integral types -------------------------------------------------- + +data Int -- builtin datatype of fixed size integers +data Integer -- builtin datatype of arbitrary size integers + +instance Eq Integer where + (==) x y = primCompareInteger x y == 0 + +instance Ord Integer where + compare x y = case primCompareInteger x y of + -1 -> LT + 0 -> EQ + 1 -> GT + +instance Eq Int where + (==) = primEqInt + (/=) = primNeInt + +instance Ord Int where + (<) = primLtInt + (<=) = primLeInt + (>=) = primGeInt + (>) = primGtInt + +instance Num Int where + (+) = primPlusInt + (-) = primMinusInt + negate = primNegateInt + (*) = primTimesInt + abs = absReal + signum = signumReal + fromInteger = primIntegerToInt + fromInt x = x + +instance Bounded Int where + minBound = primMinInt + maxBound = primMaxInt + +instance Num Integer where + (+) = primPlusInteger + (-) = primMinusInteger + negate = primNegateInteger + (*) = primTimesInteger + abs = absReal + signum = signumReal + fromInteger x = x + fromInt = primIntToInteger + +absReal x | x >= 0 = x + | otherwise = -x + +signumReal x | x == 0 = 0 + | x > 0 = 1 + | otherwise = -1 + +instance Real Int where + toRational x = toInteger x % 1 + +instance Real Integer where + toRational x = x % 1 + +instance Integral Int where + quotRem = primQuotRemInt + toInteger = primIntToInteger + toInt x = x + +instance Integral Integer where + quotRem = primQuotRemInteger + divMod = primDivModInteger + toInteger = id + toInt = primIntegerToInt + +instance Ix Int where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = i - m + | otherwise = error "index: Index out of range" + inRange (m,n) i = m <= i && i <= n + +instance Ix Integer where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = fromInteger (i - m) + | otherwise = error "index: Index out of range" + inRange (m,n) i = m <= i && i <= n + +instance Enum Int where + toEnum = id + fromEnum = id + enumFrom = numericEnumFrom + enumFromTo = numericEnumFromTo + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +instance Enum Integer where + toEnum = primIntToInteger + fromEnum = primIntegerToInt + enumFrom = numericEnumFrom + enumFromTo = numericEnumFromTo + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +numericEnumFrom :: Real a => a -> [a] +numericEnumFromThen :: Real a => a -> a -> [a] +numericEnumFromTo :: Real a => a -> a -> [a] +numericEnumFromThenTo :: Real a => a -> a -> a -> [a] +numericEnumFrom n = n : (numericEnumFrom $! (n+1)) +numericEnumFromThen n m = iterate ((m-n)+) n +numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n) +numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n') + where p | n' > n = (<= m) + | otherwise = (>= m) + +instance Read Int where + readsPrec p = readSigned readDec + +instance Show Int where + showsPrec p n + | n == minBound = showSigned showInt p (toInteger n) + | otherwise = showSigned showInt p n + +instance Read Integer where + readsPrec p = readSigned readDec + +instance Show Integer where + showsPrec = showSigned showInt + +-- Standard Floating types -------------------------------------------------- + +data Float -- builtin datatype of single precision floating point numbers +data Double -- builtin datatype of double precision floating point numbers + +instance Eq Float where + (==) = primEqFloat + (/=) = primNeFloat + +instance Ord Float where + (<) = primLtFloat + (<=) = primLeFloat + (>=) = primGeFloat + (>) = primGtFloat + +instance Num Float where + (+) = primPlusFloat + (-) = primMinusFloat + negate = primNegateFloat + (*) = primTimesFloat + abs = absReal + signum = signumReal + fromInteger = primIntegerToFloat + fromInt = primIntToFloat + + + +instance Eq Double where + (==) = primEqDouble + (/=) = primNeDouble + +instance Ord Double where + (<) = primLtDouble + (<=) = primLeDouble + (>=) = primGeDouble + (>) = primGtDouble + +instance Num Double where + (+) = primPlusDouble + (-) = primMinusDouble + negate = primNegateDouble + (*) = primTimesDouble + abs = absReal + signum = signumReal + fromInteger = primIntegerToDouble + fromInt = primIntToDouble + + + +instance Real Float where + toRational = floatToRational + +instance Real Double where + toRational = doubleToRational + +-- Calls to these functions are optimised when passed as arguments to +-- fromRational. +floatToRational :: Float -> Rational +doubleToRational :: Double -> Rational +floatToRational x = realFloatToRational x +doubleToRational x = realFloatToRational x + +realFloatToRational x = (m%1)*(b%1)^^n + where (m,n) = decodeFloat x + b = floatRadix x + +instance Fractional Float where + (/) = primDivideFloat + fromRational = rationalToRealFloat + fromDouble = primDoubleToFloat + + +instance Fractional Double where + (/) = primDivideDouble + fromRational = rationalToRealFloat + fromDouble x = x + +rationalToRealFloat x = x' + where x' = f e + f e = if e' == e then y else f e' + where y = encodeFloat (round (x * (1%b)^^e)) e + (_,e') = decodeFloat y + (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' + / fromInteger (denominator x)) + b = floatRadix x' + +instance Floating Float where + pi = 3.14159265358979323846 + exp = primExpFloat + log = primLogFloat + sqrt = primSqrtFloat + sin = primSinFloat + cos = primCosFloat + tan = primTanFloat + asin = primAsinFloat + acos = primAcosFloat + atan = primAtanFloat + +instance Floating Double where + pi = 3.14159265358979323846 + exp = primExpDouble + log = primLogDouble + sqrt = primSqrtDouble + sin = primSinDouble + cos = primCosDouble + tan = primTanDouble + asin = primAsinDouble + acos = primAcosDouble + atan = primAtanDouble + +instance RealFrac Float where + properFraction = floatProperFraction + +instance RealFrac Double where + properFraction = floatProperFraction + +floatProperFraction x + | n >= 0 = (fromInteger m * fromInteger b ^ n, 0) + | otherwise = (fromInteger w, encodeFloat r n) + where (m,n) = decodeFloat x + b = floatRadix x + (w,r) = quotRem m (b^(-n)) + +instance RealFloat Float where + floatRadix _ = toInteger primRadixFloat + floatDigits _ = primDigitsFloat + floatRange _ = (primMinExpFloat,primMaxExpFloat) + encodeFloat = primEncodeFloatZ + decodeFloat = primDecodeFloatZ + isNaN = primIsNaNFloat + isInfinite = primIsInfiniteFloat + isDenormalized= primIsDenormalizedFloat + isNegativeZero= primIsNegativeZeroFloat + isIEEE = const primIsIEEEFloat + +instance RealFloat Double where + floatRadix _ = toInteger primRadixDouble + floatDigits _ = primDigitsDouble + floatRange _ = (primMinExpDouble,primMaxExpDouble) + encodeFloat = primEncodeDoubleZ + decodeFloat = primDecodeDoubleZ + isNaN = primIsNaNDouble + isInfinite = primIsInfiniteDouble + isDenormalized= primIsDenormalizedDouble + isNegativeZero= primIsNegativeZeroDouble + isIEEE = const primIsIEEEDouble + +instance Enum Float where + toEnum = primIntToFloat + fromEnum = truncate + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo n m = numericEnumFromTo n (m+1/2) + enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2) + +instance Enum Double where + toEnum = primIntToDouble + fromEnum = truncate + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo n m = numericEnumFromTo n (m+1/2) + enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2) + +instance Read Float where + readsPrec p = readSigned readFloat + +instance Show Float where + showsPrec p = showFloat + --error "should call showFloat" + +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" + +-- Some standard functions -------------------------------------------------- + +fst :: (a,b) -> a +fst (x,_) = x + +snd :: (a,b) -> b +snd (_,y) = y + +curry :: ((a,b) -> c) -> (a -> b -> c) +curry f x y = f (x,y) + +uncurry :: (a -> b -> c) -> ((a,b) -> c) +uncurry f p = f (fst p) (snd p) + +id :: a -> a +id x = x + +const :: a -> b -> a +const k _ = k + +(.) :: (b -> c) -> (a -> b) -> (a -> c) +(f . g) x = f (g x) + +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +($) :: (a -> b) -> a -> b +f $ x = f x + +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x = if p x then x else until p f (f x) + +asTypeOf :: a -> a -> a +asTypeOf = const + +error :: String -> a +error msg = primRaise (ErrorCall msg) + +undefined :: a +undefined | False = undefined + +-- Standard functions on rational numbers {PreludeRatio} -------------------- + +data Integral a => Ratio a = a :% a deriving (Eq) +type Rational = Ratio Integer + +(%) :: Integral a => a -> a -> Ratio a +x % y = reduce (x * signum y) (abs y) + +reduce :: Integral a => a -> a -> Ratio a +reduce x y | y == 0 = error "Ratio.%: zero denominator" + | otherwise = (x `quot` d) :% (y `quot` d) + where d = gcd x y + +numerator, denominator :: Integral a => Ratio a -> a +numerator (x :% y) = x +denominator (x :% y) = y + +instance Integral a => Ord (Ratio a) where + compare (x:%y) (x':%y') = compare (x*y') (x'*y) + +instance Integral a => Num (Ratio a) where + (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') + (x:%y) * (x':%y') = reduce (x*x') (y*y') + negate (x :% y) = negate x :% y + abs (x :% y) = abs x :% y + signum (x :% y) = signum x :% 1 + fromInteger x = fromInteger x :% 1 + fromInt = intToRatio + +-- Hugs optimises code of the form fromRational (intToRatio x) +intToRatio :: Integral a => Int -> Ratio a +intToRatio x = fromInt x :% 1 + +instance Integral a => Real (Ratio a) where + toRational (x:%y) = toInteger x :% toInteger y + +instance Integral a => Fractional (Ratio a) where + (x:%y) / (x':%y') = (x*y') % (y*x') + recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + fromRational (x:%y) = fromInteger x :% fromInteger y + fromDouble = doubleToRatio + +-- Hugs optimises code of the form fromRational (doubleToRatio x) +doubleToRatio :: Integral a => Double -> Ratio a +doubleToRatio x + | n>=0 = (fromInteger m * fromInteger b ^ n) % 1 + | otherwise = fromInteger m % (fromInteger b ^ (-n)) + where (m,n) = decodeFloat x + b = floatRadix x + +instance Integral a => RealFrac (Ratio a) where + properFraction (x:%y) = (fromIntegral q, r:%y) + where (q,r) = quotRem x y + +instance Integral a => Enum (Ratio a) where + toEnum = fromInt + fromEnum = truncate + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + +instance (Read a, Integral a) => Read (Ratio a) where + readsPrec p = readParen (p > 7) + (\r -> [(x%y,u) | (x,s) <- reads r, + ("%",t) <- lex s, + (y,u) <- reads t ]) + +instance Integral a => Show (Ratio a) where + showsPrec p (x:%y) = showParen (p > 7) + (shows x . showString " % " . shows y) + +approxRational :: RealFrac a => a -> a -> Rational +approxRational x eps = simplest (x-eps) (x+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr@(n:%d) = toRational x + (n':%d') = toRational y + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + (n'':%d'') = simplest' d' r' d r + +-- Standard list functions {PreludeList} ------------------------------------ + +head :: [a] -> a +head (x:_) = x + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs + +tail :: [a] -> [a] +tail (_:xs) = xs + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs + +null :: [a] -> Bool +null [] = True +null (_:_) = False + +(++) :: [a] -> [a] -> [a] +[] ++ ys = ys +(x:xs) ++ ys = x : (xs ++ ys) + +map :: (a -> b) -> [a] -> [b] +map f xs = [ f x | x <- xs ] + +filter :: (a -> Bool) -> [a] -> [a] +filter p xs = [ x | x <- xs, p x ] + +concat :: [[a]] -> [a] +concat = foldr (++) [] + +length :: [a] -> Int +length = foldl' (\n _ -> n + 1) 0 + +(!!) :: [b] -> Int -> b +(x:_) !! 0 = x +(_:xs) !! n | n>0 = xs !! (n-1) +(_:_) !! _ = error "Prelude.!!: negative index" +[] !! _ = error "Prelude.!!: index too large" + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z [] = z +foldl f z (x:xs) = foldl f (f z x) xs + +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' f a [] = a +foldl' f a (x:xs) = (foldl' f $! f a x) xs + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs + +foldr :: (a -> b -> b) -> b -> [a] -> b +foldr f z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 f [x] = x +foldr1 f (x:xs) = f x (foldr1 f xs) + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs + +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) + +repeat :: a -> [a] +repeat x = xs where xs = x:xs + +replicate :: Int -> a -> [a] +replicate n x = take n (repeat x) + +cycle :: [a] -> [a] +cycle [] = error "Prelude.cycle: empty list" +cycle xs = xs' where xs'=xs++xs' + +take :: Int -> [a] -> [a] +take 0 _ = [] +take _ [] = [] +take n (x:xs) | n>0 = x : take (n-1) xs +take _ _ = error "Prelude.take: negative argument" + +drop :: Int -> [a] -> [a] +drop 0 xs = xs +drop _ [] = [] +drop n (_:xs) | n>0 = drop (n-1) xs +drop _ _ = error "Prelude.drop: negative argument" + +splitAt :: Int -> [a] -> ([a], [a]) +splitAt 0 xs = ([],xs) +splitAt _ [] = ([],[]) +splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs +splitAt _ _ = error "Prelude.splitAt: negative argument" + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p [] = [] +takeWhile p (x:xs) + | p x = x : takeWhile p xs + | otherwise = [] + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs + +span, break :: (a -> Bool) -> [a] -> ([a],[a]) +span p [] = ([],[]) +span p xs@(x:xs') + | p x = (x:ys, zs) + | otherwise = ([],xs) + where (ys,zs) = span p xs' +break p = span (not . p) + +lines :: String -> [String] +lines "" = [] +lines s = let (l,s') = break ('\n'==) s + in l : case s' of [] -> [] + (_:s'') -> lines s'' + +words :: String -> [String] +words s = case dropWhile isSpace s of + "" -> [] + s' -> w : words s'' + where (w,s'') = break isSpace s' + +unlines :: [String] -> String +unlines = concatMap (\l -> l ++ "\n") + +unwords :: [String] -> String +unwords [] = [] +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws + +reverse :: [a] -> [a] +reverse = foldl (flip (:)) [] + +and, or :: [Bool] -> Bool +and = foldr (&&) True +or = foldr (||) False + +any, all :: (a -> Bool) -> [a] -> Bool +any p = or . map p +all p = and . map p + +elem, notElem :: Eq a => a -> [a] -> Bool +elem = any . (==) +notElem = all . (/=) + +lookup :: Eq a => a -> [(a,b)] -> Maybe b +lookup k [] = Nothing +lookup k ((x,y):xys) + | k==x = Just y + | otherwise = lookup k xys + +sum, product :: Num a => [a] -> a +sum = foldl' (+) 0 +product = foldl' (*) 1 + +maximum, minimum :: Ord a => [a] -> a +maximum = foldl1 max +minimum = foldl1 min + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = concat . map f + +zip :: [a] -> [b] -> [(a,b)] +zip = zipWith (\a b -> (a,b)) + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 = zipWith3 (\a b c -> (a,b,c)) + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z (a:as) (b:bs) = z a b : zipWith z as bs +zipWith _ _ _ = [] + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3 z as bs cs +zipWith3 _ _ _ _ = [] + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], []) + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) + +-- PreludeText ---------------------------------------------------------------- + +reads :: Read a => ReadS a +reads = readsPrec 0 + +shows :: Show a => a -> ShowS +shows = showsPrec 0 + +read :: Read a => String -> a +read s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + [] -> error "Prelude.read: no parse" + _ -> error "Prelude.read: ambiguous parse" + +showChar :: Char -> ShowS +showChar = (:) + +showString :: String -> ShowS +showString = (++) + +showParen :: Bool -> ShowS -> ShowS +showParen b p = if b then showChar '(' . p . showChar ')' else p + +showField :: Show a => String -> a -> ShowS +showField m v = showString m . showChar '=' . shows v + +readParen :: Bool -> ReadS a -> ReadS a +readParen b g = if b then mandatory else optional + where optional r = g r ++ mandatory r + mandatory r = [(x,u) | ("(",s) <- lex r, + (x,t) <- optional s, + (")",u) <- lex t ] + + +readField :: Read a => String -> ReadS a +readField m s0 = [ r | (t, s1) <- lex s0, t == m, + ("=",s2) <- lex s1, + r <- reads s2 ] + +lex :: ReadS String +lex "" = [("","")] +lex (c:s) | isSpace c = lex (dropWhile isSpace s) +lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, + ch /= "'" ] +lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] + where + lexString ('"':s) = [("\"",s)] + lexString s = [(ch++str, u) + | (ch,t) <- lexStrItem s, + (str,u) <- lexString t ] + + lexStrItem ('\\':'&':s) = [("\\&",s)] + lexStrItem ('\\':c:s) | isSpace c + = [("",t) | '\\':t <- [dropWhile isSpace s]] + lexStrItem s = lexLitChar s + +lex (c:s) | isSingle c = [([c],s)] + | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]] + | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] + | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], + (fe,t) <- lexFracExp s ] + | otherwise = [] -- bad character + where + isSingle c = c `elem` ",;()[]{}_`" + isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" + isIdChar c = isAlphaNum c || c `elem` "_'" + + lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, + (e,u) <- lexExp t ] + lexFracExp s = [("",s)] + + lexExp (e:s) | e `elem` "eE" + = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", + (ds,u) <- lexDigits t] ++ + [(e:ds,t) | (ds,t) <- lexDigits s] + lexExp s = [("",s)] + +lexDigits :: ReadS String +lexDigits = nonnull isDigit + +nonnull :: (Char -> Bool) -> ReadS String +nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] + +lexLitChar :: ReadS String +lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] + where + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] + lexEsc s@(d:_) | isDigit d = lexDigits s + lexEsc s@(c:_) | isUpper c + = let table = ('\DEL',"DEL") : asciiTab + in case [(mne,s') | (c, mne) <- table, + ([],s') <- [lexmatch mne s]] + of (pr:_) -> [pr] + [] -> [] + lexEsc _ = [] +lexLitChar (c:s) = [([c],s)] +lexLitChar "" = [] + +isOctDigit c = c >= '0' && c <= '7' +isHexDigit c = isDigit c || c >= 'A' && c <= 'F' + || c >= 'a' && c <= 'f' + +lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a]) +lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys +lexmatch xs ys = (xs,ys) + +asciiTab = zip ['\NUL'..' '] + ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + "SP"] + +readLitChar :: ReadS Char +readLitChar ('\\':s) = readEsc s + where + readEsc ('a':s) = [('\a',s)] + readEsc ('b':s) = [('\b',s)] + readEsc ('f':s) = [('\f',s)] + readEsc ('n':s) = [('\n',s)] + readEsc ('r':s) = [('\r',s)] + readEsc ('t':s) = [('\t',s)] + readEsc ('v':s) = [('\v',s)] + readEsc ('\\':s) = [('\\',s)] + readEsc ('"':s) = [('"',s)] + readEsc ('\'':s) = [('\'',s)] + readEsc ('^':c:s) | c >= '@' && c <= '_' + = [(toEnum (fromEnum c - fromEnum '@'), s)] + readEsc s@(d:_) | isDigit d + = [(toEnum n, t) | (n,t) <- readDec s] + readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s] + readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s] + readEsc s@(c:_) | isUpper c + = let table = ('\DEL',"DEL") : asciiTab + in case [(c,s') | (c, mne) <- table, + ([],s') <- [lexmatch mne s]] + of (pr:_) -> [pr] + [] -> [] + readEsc _ = [] +readLitChar (c:s) = [(c,s)] + +showLitChar :: Char -> ShowS +showLitChar c | c > '\DEL' = showChar '\\' . + protectEsc isDigit (shows (fromEnum c)) +showLitChar '\DEL' = showString "\\DEL" +showLitChar '\\' = showString "\\\\" +showLitChar c | c >= ' ' = showChar c +showLitChar '\a' = showString "\\a" +showLitChar '\b' = showString "\\b" +showLitChar '\f' = showString "\\f" +showLitChar '\n' = showString "\\n" +showLitChar '\r' = showString "\\r" +showLitChar '\t' = showString "\\t" +showLitChar '\v' = showString "\\v" +showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO") +showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c)) + +protectEsc p f = f . cont + where cont s@(c:_) | p c = "\\&" ++ s + cont s = s + +-- Unsigned readers for various bases +readDec, readOct, readHex :: Integral a => ReadS a +readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0') +readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0') +readHex = readInt 16 isHexDigit hex + where hex d = fromEnum d - + (if isDigit d + then fromEnum '0' + else fromEnum (if isUpper d then 'A' else 'a') - 10) + +-- readInt reads a string of digits using an arbitrary base. +-- Leading minus signs must be handled elsewhere. + +readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a +readInt radix isDig digToInt s = + [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r) + | (ds,r) <- nonnull isDig s ] + +-- showInt is used for positive numbers only +showInt :: Integral a => a -> ShowS +showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers" + | otherwise = + let (n',d) = quotRem n 10 + r' = toEnum (fromEnum '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' + +readSigned:: Real a => ReadS a -> ReadS a +readSigned readPos = readParen False read' + where read' r = read'' r ++ + [(-x,t) | ("-",s) <- lex r, + (x,t) <- read'' s] + read'' r = [(n,s) | (str,s) <- lex r, + (n,"") <- readPos str] + +showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS +showSigned showPos p x = if x < 0 then showParen (p > 6) + (showChar '-' . showPos (-x)) + else showPos x + +readFloat :: RealFloat a => ReadS a +readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, + (k,t) <- readExp s] + where readFix r = [(read (ds++ds'), length ds', t) + | (ds, s) <- lexDigits r + , (ds',t) <- lexFrac s ] + + lexFrac ('.':s) = lexDigits s + lexFrac s = [("",s)] + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = [(0,s)] + + readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] + readExp' ('+':s) = readDec s + readExp' s = readDec s + + +-- Hooks for primitives: ----------------------------------------------------- +-- Do not mess with these! + +primCompAux :: Ord a => a -> a -> Ordering -> Ordering +primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT + +primPmInt :: Num a => Int -> a -> Bool +primPmInt n x = fromInt n == x + +primPmInteger :: Num a => Integer -> a -> Bool +primPmInteger n x = fromInteger n == x + +primPmFlt :: Fractional a => Double -> a -> Bool +primPmFlt n x = fromDouble n == x + +-- ToDo: make the message more informative. +primPmFail :: a +primPmFail = error "Pattern Match Failure" +primPmFailBUG :: a +primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++ + "**Please** report to v-julsew@microsoft.com. Thx!\n") + +-- used in desugaring Foreign functions +primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a +primMkIO = ST + +-- The following primitives are only needed if (n+k) patterns are enabled: +primPmNpk :: Integral a => Int -> a -> Maybe a +primPmNpk n x = if n'<=x then Just (x-n') else Nothing + where n' = fromInt n + +primPmSub :: Integral a => Int -> a -> a +primPmSub n x = x - fromInt n + +-- Unpack strings generated by the Hugs code generator. +-- Strings can contain \0 provided they're coded right. +-- +-- ToDo: change this (and Hugs code generator) to use ByteArrays + +primUnpackString :: Addr -> String +primUnpackString a = unpack 0 + where + -- The following decoding is based on evalString in the old machine.c + unpack i + | c == '\0' = [] + | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1) + then '\\' : unpack (i+2) + else '\0' : unpack (i+2) + | otherwise = c : unpack (i+1) + where + c = primIndexCharOffAddr a i + + +-- Monadic I/O: -------------------------------------------------------------- + +type FilePath = String + +--data IOError = ... +--instance Eq IOError ... +--instance Show IOError ... + +data IOError = IOError String +instance Show IOError where + showsPrec _ (IOError s) = showString ("I/O error: " ++ s) + +ioError :: IOError -> IO a +ioError (IOError s) = primRaise (IOExcept s) + +userError :: String -> IOError +userError s = primRaise (ErrorCall s) + +catch :: IO a -> (IOError -> IO a) -> IO a +catch x eh = primCatch x (eh.exception2ioerror) + where + exception2ioerror (IOExcept s) = IOError s + exception2ioerror other = IOError (show other) + +putChar :: Char -> IO () +putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c) + +putStr :: String -> IO () +putStr s = --mapM_ putChar s -- correct, but slow + nh_stdout >>= \h -> + let loop [] = return () + loop (c:cs) = nh_write h (primCharToInt c) >> loop cs + in loop s + +putStrLn :: String -> IO () +putStrLn s = do { putStr s; putChar '\n' } + +print :: Show a => a -> IO () +print = putStrLn . show + +getChar :: IO Char +getChar = unsafeInterleaveIO ( + nh_stdin >>= \h -> + nh_read h >>= \ci -> + return (primIntToChar ci) + ) + +getLine :: IO String +getLine = do c <- getChar + if c=='\n' then return "" + else do cs <- getLine + return (c:cs) + +getContents :: IO String +getContents = nh_stdin >>= \h -> readfromhandle h + +interact :: (String -> String) -> IO () +interact f = getContents >>= (putStr . f) + +readFile :: FilePath -> IO String +readFile fname + = fileopen_sendname fname >>= \ptr -> + nh_open ptr 0 >>= \h -> + nh_free ptr >> + nh_errno >>= \errno -> + if (h == 0 || errno /= 0) + then (ioError.IOError) ("readFile: can't open file " ++ fname) + else readfromhandle h + +writeFile :: FilePath -> String -> IO () +writeFile fname contents + = fileopen_sendname fname >>= \ptr -> + nh_open ptr 1 >>= \h -> + nh_free ptr >> + nh_errno >>= \errno -> + if (h == 0 || errno /= 0) + then (ioError.IOError) ("writeFile: can't create file " ++ fname) + else writetohandle fname h contents + + +appendFile :: FilePath -> String -> IO () +appendFile fname contents + = fileopen_sendname fname >>= \ptr -> + nh_open ptr 2 >>= \h -> + nh_free ptr >> + nh_errno >>= \errno -> + if (h == 0 || errno /= 0) + then (ioError.IOError) ("appendFile: can't open file " ++ fname) + else writetohandle fname h contents + + +-- raises an exception instead of an error +readIO :: Read a => String -> IO a +readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> ioError (userError "PreludeIO.readIO: no parse") + _ -> ioError (userError + "PreludeIO.readIO: ambiguous parse") + +readLn :: Read a => IO a +readLn = do l <- getLine + r <- readIO l + return r + + +-- End of Hugs standard prelude ---------------------------------------------- + +data Exception + = ErrorCall String + | IOExcept String + +instance Show Exception where + showsPrec _ (ErrorCall s) = showString ("error: " ++ s) + showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s) + +data IOResult = IOResult deriving (Show) + +type FILE_STAR = Int + +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_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_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 + in + loop 0 fname + +readfromhandle :: FILE_STAR -> IO String +readfromhandle h + = unsafeInterleaveIO ( + nh_read h >>= \ci -> + if ci == -1 {-EOF-} then return "" else + readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile) + ) + +writetohandle :: String -> FILE_STAR -> String -> IO () +writetohandle fname h [] + = nh_close h >> + nh_errno >>= \errno -> + if errno == 0 + then return () + else error ( "writeFile/appendFile: error closing file " ++ fname) +writetohandle fname h (c:cs) + = nh_write h (primCharToInt c) >> + writetohandle fname h cs + +------------------------------------------------------------------------------ +-- ST, IO -------------------------------------------------------------------- +------------------------------------------------------------------------------ + +newtype ST s a = ST (s -> (a,s)) + +data RealWorld +type IO a = ST RealWorld a + + +--runST :: (forall s. ST s a) -> a +runST :: ST RealWorld a -> a +runST m = fst (unST m theWorld) + where + theWorld :: RealWorld + theWorld = error "runST: entered the RealWorld" + +unST (ST a) = a + +instance Functor (ST s) where + fmap f x = x >>= (return . f) + +instance Monad (ST s) where + m >> k = m >>= \ _ -> k + return x = ST $ \ s -> (x,s) + m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' } + + +-- used when Hugs invokes top level function +primRunIO :: IO () -> () +primRunIO m + = protect (fst (unST m realWorld)) + where + realWorld = error "panic: Hugs entered the real world" + protect :: () -> () + protect comp + = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld)) + +trace :: String -> a -> a +trace s x + = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) + +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO = unsafeInterleaveST + + +------------------------------------------------------------------------------ +-- Addr, ForeignObj, Prim*Array ---------------------------------------------- +------------------------------------------------------------------------------ + +data Addr + +nullAddr = primIntToAddr 0 + +instance Eq Addr where + (==) = primEqAddr + (/=) = primNeAddr + +instance Ord Addr where + (<) = primLtAddr + (<=) = primLeAddr + (>=) = primGeAddr + (>) = primGtAddr + + +data ForeignObj +makeForeignObj :: Addr -> IO ForeignObj +makeForeignObj = primMakeForeignObj + + +data PrimArray a -- immutable arrays with Int indices +data PrimByteArray + +data Ref s a -- mutable variables +data PrimMutableArray s a -- mutable arrays with Int indices +data PrimMutableByteArray s + + +------------------------------------------------------------------------------ +-- hooks to call libHS_cbits ------------------------------------------------- +------------------------------------------------------------------------------ +{- +type FILE_OBJ = ForeignObj -- as passed into functions +type CString = PrimByteArray +type How = Int +type Binary = Int +type OpenFlags = Int +type IOFileAddr = Addr -- as returned from functions +type FD = Int +type OpenStdFlags = Int +type Readable = Int -- really Bool +type Exclusive = Int -- really Bool +type RC = Int -- standard return code +type Bytes = PrimMutableByteArray RealWorld +type Flush = Int -- really Bool + +foreign import stdcall "libHS_cbits.so" "freeStdFileObject" + freeStdFileObject :: ForeignObj -> IO () + +foreign import stdcall "libHS_cbits.so" "freeFileObject" + freeFileObject :: ForeignObj -> IO () + +foreign import stdcall "libHS_cbits.so" "setBuf" + prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () + +foreign import stdcall "libHS_cbits.so" "getBufSize" + prim_getBufSize :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "inputReady" + prim_inputReady :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "fileGetc" + prim_fileGetc :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "fileLookAhead" + prim_fileLookAhead :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "readBlock" + prim_readBlock :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "readLine" + prim_readLine :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "readChar" + prim_readChar :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "writeFileObject" + prim_writeFileObject :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "filePutc" + prim_filePutc :: FILE_OBJ -> Char -> IO RC + +foreign import stdcall "libHS_cbits.so" "getBufStart" + prim_getBufStart :: FILE_OBJ -> Int -> IO Addr + +foreign import stdcall "libHS_cbits.so" "getWriteableBuf" + prim_getWriteableBuf :: FILE_OBJ -> IO Addr + +foreign import stdcall "libHS_cbits.so" "getBufWPtr" + prim_getBufWPtr :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "setBufWPtr" + prim_setBufWPtr :: FILE_OBJ -> Int -> IO () + +foreign import stdcall "libHS_cbits.so" "closeFile" + prim_closeFile :: FILE_OBJ -> Flush -> IO RC + +foreign import stdcall "libHS_cbits.so" "fileEOF" + prim_fileEOF :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "setBuffering" + prim_setBuffering :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "flushFile" + prim_flushFile :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "getBufferMode" + prim_getBufferMode :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "seekFileP" + prim_seekFileP :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "setTerminalEcho" + prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "getTerminalEcho" + prim_getTerminalEcho :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "isTerminalDevice" + prim_isTerminalDevice :: FILE_OBJ -> IO RC + +foreign import stdcall "libHS_cbits.so" "setConnectedTo" + prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () + +foreign import stdcall "libHS_cbits.so" "ungetChar" + prim_ungetChar :: FILE_OBJ -> Char -> IO RC + +foreign import stdcall "libHS_cbits.so" "readChunk" + prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "writeBuf" + prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC + +foreign import stdcall "libHS_cbits.so" "getFileFd" + prim_getFileFd :: FILE_OBJ -> IO FD + +foreign import stdcall "libHS_cbits.so" "fileSize_int64" + prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC + +foreign import stdcall "libHS_cbits.so" "getFilePosn" + prim_getFilePosn :: FILE_OBJ -> IO Int + +foreign import stdcall "libHS_cbits.so" "setFilePosn" + prim_setFilePosn :: FILE_OBJ -> Int -> IO Int + +foreign import stdcall "libHS_cbits.so" "getConnFileFd" + prim_getConnFileFd :: FILE_OBJ -> IO FD + +foreign import stdcall "libHS_cbits.so" "allocMemory__" + prim_allocMemory__ :: Int -> IO Addr + +foreign import stdcall "libHS_cbits.so" "getLock" + prim_getLock :: FD -> Exclusive -> IO RC + +foreign import stdcall "libHS_cbits.so" "openStdFile" + prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr + +foreign import stdcall "libHS_cbits.so" "openFile" + prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr + +foreign import stdcall "libHS_cbits.so" "freeFileObject" + prim_freeFileObject :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "freeStdFileObject" + prim_freeStdFileObject :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" + const_BUFSIZ :: Int + +foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" + prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" + prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" + prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" + prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import stdcall "libHS_cbits.so" "getErrStr__" + prim_getErrStr__ :: IO Addr + +foreign import stdcall "libHS_cbits.so" "getErrNo__" + prim_getErrNo__ :: IO Int + +foreign import stdcall "libHS_cbits.so" "getErrType__" + prim_getErrType__ :: IO Int + +--foreign import stdcall "libHS_cbits.so" "seekFile_int64" +-- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC +-} + +-- showFloat ------------------------------------------------------------------ + +showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFloat :: (RealFloat a) => a -> ShowS + +showEFloat d x = showString (formatRealFloat FFExponent d x) +showFFloat d x = showString (formatRealFloat FFFixed d x) +showGFloat d x = showString (formatRealFloat FFGeneric d x) +showFloat = showGFloat Nothing + +-- These are the format types. This type is not exported. + +data FFFormat = FFExponent | FFFixed | FFGeneric + +formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String +formatRealFloat fmt decs x = s + where base = 10 + s = if isNaN x then + "NaN" + else if isInfinite x then + if x < 0 then "-Infinity" else "Infinity" + else if x < 0 || isNegativeZero x then + '-' : doFmt fmt (floatToDigits (toInteger base) (-x)) + else + doFmt fmt (floatToDigits (toInteger base) x) + doFmt fmt (is, e) = + let ds = map intToDigit is + in case fmt of + FFGeneric -> + doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) + (is, e) + FFExponent -> + case decs of + Nothing -> + case ds of + ['0'] -> "0.0e0" + [d] -> d : ".0e" ++ show (e-1) + d:ds -> d : '.' : ds ++ 'e':show (e-1) + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0':'.':take dec' (repeat '0') ++ "e0" + _ -> + let (ei, is') = roundTo base (dec'+1) is + d:ds = map intToDigit + (if ei > 0 then init is' else is') + in d:'.':ds ++ "e" ++ show (e-1+ei) + FFFixed -> + case decs of + Nothing -> + let f 0 s ds = mk0 s ++ "." ++ mk0 ds + f n s "" = f (n-1) (s++"0") "" + f n s (d:ds) = f (n-1) (s++[d]) ds + mk0 "" = "0" + mk0 s = s + in f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let (ei, is') = roundTo base (dec' + e) is + (ls, rs) = splitAt (e+ei) (map intToDigit is') + in (if null ls then "0" else ls) ++ + (if null rs then "" else '.' : rs) + else + let (ei, is') = roundTo base dec' + (replicate (-e) 0 ++ is) + d : ds = map intToDigit + (if ei > 0 then is' else 0:is') + in d : '.' : ds + +roundTo :: Int -> Int -> [Int] -> (Int, [Int]) +roundTo base d is = case f d is of + (0, is) -> (0, is) + (1, is) -> (1, 1 : is) + where b2 = base `div` 2 + f n [] = (0, replicate n 0) + f 0 (i:_) = (if i >= b2 then 1 else 0, []) + f d (i:is) = + let (c, ds) = f (d-1) is + i' = c + i + in if i' == base then (1, 0:ds) else (0, i':ds) + +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R. K. Dybvig, in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- This function returns a list of digits (Ints in [0..base-1]) and an +-- exponent. + +floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) + +floatToDigits _ 0 = ([0], 0) +floatToDigits base x = + let (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = let n = minExp - e0 + in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + + (r, s, mUp, mDn) = + if e >= 0 then + let be = b^e in + if f == b^(p-1) then + (f*be*b*2, 2*b, be*b, b) + else + (f*be*2, 2, be, be) + else + if e > minExp && f == b^(p-1) then + (f*b*2, b^(-e+1)*2, b, 1) + else + (f*2, b^(-e)*2, 1, 1) + k = + let k0 = + + 0 + + fixup n = + if n >= 0 then + if r + mUp <= expt base n * s then n else fixup (n+1) + else + if expt base (-n) * (r + mUp) <= s then n + else fixup (n+1) + in fixup k0 + + gen ds rn sN mUpN mDnN = + let (dn, rn') = (rn * base) `divMod` sN + mUpN' = mUpN * base + mDnN' = mDnN * base + in case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + rds = + if k >= 0 then + gen [] r (s * expt base k) mUp mDn + else + let bk = expt base (-k) + 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 diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index 9c0b922..a9c5fa1 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.6 $ - * $Date: 1999/03/02 19:52:24 $ + * $Revision: 1.7 $ + * $Date: 1999/03/09 14:51:19 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -423,12 +423,25 @@ void asmEndBCO( AsmBCO bco ) * * ------------------------------------------------------------------------*/ -static void asmInstr( AsmBCO bco, StgWord i ) +static void asmInstr8 ( AsmBCO bco, StgWord i ) { + if (i >= 256) { + fprintf(stderr, "too big (256)\n"); + } 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 */ + insertInstrs(&(bco->is),i / 256); + insertInstrs(&(bco->is),i % 256); +} + static void asmPtr( AsmBCO bco, AsmObject x ) { insertPtrs( &bco->object.ptrs, x ); @@ -505,6 +518,231 @@ static StgWord repSizeW( AsmRep rep ) } /* -------------------------------------------------------------------------- + * Instruction emission + * ------------------------------------------------------------------------*/ + +static void emit_i0 ( AsmBCO bco, Instr opcode ) +{ + asmInstr8(bco,opcode); +} + +static void emit_i1 ( AsmBCO bco, Instr opcode, int arg1 ) +{ + asmInstr8(bco,opcode); + asmInstr8(bco,arg1); +} + +static void emit_i2 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +{ + asmInstr8(bco,opcode); + asmInstr8(bco,arg1); + asmInstr8(bco,arg2); +} + +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); + } +} + +#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); + } +} +#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); + } +} + +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); + } +} + +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); + } +} + +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); + } +} + +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); + } +} + +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); + } +} + +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); + } +} + +#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); + } +} +#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); + } +} + +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); + } +} + +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); + } +} + +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); + } +} + +static void emit_i_RETADDR ( 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); + } +} + +static void emit_i_CONST ( 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); + } +} + + +/* -------------------------------------------------------------------------- * Arg checks. * ------------------------------------------------------------------------*/ @@ -518,8 +756,7 @@ void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg ) { nat args = bco->sp - last_arg; if (args != 0) { /* optimisation */ - asmInstr(bco,i_ARG_CHECK); - asmInstr(bco,args); + emit_i1(bco,i_ARG_CHECK,args); grabHpNonUpd(bco,PAP_sizeW(args-1)); resetHp(bco,0); } @@ -537,38 +774,47 @@ AsmVar asmBind ( AsmBCO bco, AsmRep rep ) void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) { + int offset; + + if (rep == VOID_REP) { + emit_i0(bco,i_VOID); + bco->sp += repSizeW(rep); + return; + } + + offset = bco->sp - v; switch (rep) { case BOOL_REP: case INT_REP: - asmInstr(bco,i_VAR_INT); + emit_i_VAR_INT(bco,offset); break; #ifdef PROVIDE_INT64 case INT64_REP: - asmInstr(bco,i_VAR_INT64); + emit_i_VAR_INT64(bco,offset); break; #endif #ifdef PROVIDE_WORD case WORD_REP: - asmInstr(bco,i_VAR_WORD); + emit_i_VAR_WORD(bco,offset); break; #endif #ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_VAR_ADDR); + emit_i_VAR_ADDR(bco,offset); break; #endif case CHAR_REP: - asmInstr(bco,i_VAR_CHAR); + emit_i_VAR_CHAR(bco,offset); break; case FLOAT_REP: - asmInstr(bco,i_VAR_FLOAT); + emit_i_VAR_FLOAT(bco,offset); break; case DOUBLE_REP: - asmInstr(bco,i_VAR_DOUBLE); + emit_i_VAR_DOUBLE(bco,offset); break; #ifdef PROVIDE_STABLE case STABLE_REP: - asmInstr(bco,i_VAR_STABLE); + emit_i_VAR_STABLE(bco,offset); break; #endif @@ -598,17 +844,11 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case MVAR_REP: /* MVar a */ #endif case PTR_REP: - asmInstr(bco,i_VAR); + emit_i_VAR(bco,offset); break; - - case VOID_REP: - asmInstr(bco,i_VOID); - bco->sp += repSizeW(rep); - return; /* NB we don't break! */ default: barf("asmVar %d",rep); } - asmInstr(bco,bco->sp - v); bco->sp += repSizeW(rep); } @@ -627,12 +867,10 @@ void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 ) int y = sp1 - sp2; ASSERT(x >= 0 && y >= 0); if (y != 0) { - asmInstr(bco,i_SLIDE); - asmInstr(bco,x); - asmInstr(bco,y); + emit_i_SLIDE(bco,x,y); bco->sp -= sp1 - sp2; } - asmInstr(bco,i_ENTER); + emit_i0(bco,i_ENTER); } /* -------------------------------------------------------------------------- @@ -643,42 +881,42 @@ AsmVar asmBox( AsmBCO bco, AsmRep rep ) { switch (rep) { case CHAR_REP: - asmInstr(bco,i_PACK_CHAR); + emit_i0(bco,i_PACK_CHAR); grabHpNonUpd(bco,Czh_sizeW); break; case INT_REP: - asmInstr(bco,i_PACK_INT); + emit_i0(bco,i_PACK_INT); grabHpNonUpd(bco,Izh_sizeW); break; #ifdef PROVIDE_INT64 case INT64_REP: - asmInstr(bco,i_PACK_INT64); + emit_i0(bco,i_PACK_INT64); grabHpNonUpd(bco,I64zh_sizeW); break; #endif #ifdef PROVIDE_WORD case WORD_REP: - asmInstr(bco,i_PACK_WORD); + emit_i0(bco,i_PACK_WORD); grabHpNonUpd(bco,Wzh_sizeW); break; #endif #ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_PACK_ADDR); + emit_i0(bco,i_PACK_ADDR); grabHpNonUpd(bco,Azh_sizeW); break; #endif case FLOAT_REP: - asmInstr(bco,i_PACK_FLOAT); + emit_i0(bco,i_PACK_FLOAT); grabHpNonUpd(bco,Fzh_sizeW); break; case DOUBLE_REP: - asmInstr(bco,i_PACK_DOUBLE); + emit_i0(bco,i_PACK_DOUBLE); grabHpNonUpd(bco,Dzh_sizeW); break; #ifdef PROVIDE_STABLE case STABLE_REP: - asmInstr(bco,i_PACK_STABLE); + emit_i0(bco,i_PACK_STABLE); grabHpNonUpd(bco,Stablezh_sizeW); break; #endif @@ -700,35 +938,35 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) { switch (rep) { case INT_REP: - asmInstr(bco,i_UNPACK_INT); + emit_i0(bco,i_UNPACK_INT); break; #ifdef PROVIDE_INT64 case INT64_REP: - asmInstr(bco,i_UNPACK_INT64); + emit_i0(bco,i_UNPACK_INT64); break; #endif #ifdef PROVIDE_WORD case WORD_REP: - asmInstr(bco,i_UNPACK_WORD); + emit_i0(bco,i_UNPACK_WORD); break; #endif #ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_UNPACK_ADDR); + emit_i0(bco,i_UNPACK_ADDR); break; #endif case CHAR_REP: - asmInstr(bco,i_UNPACK_CHAR); + emit_i0(bco,i_UNPACK_CHAR); break; case FLOAT_REP: - asmInstr(bco,i_UNPACK_FLOAT); + emit_i0(bco,i_UNPACK_FLOAT); break; case DOUBLE_REP: - asmInstr(bco,i_UNPACK_DOUBLE); + emit_i0(bco,i_UNPACK_DOUBLE); break; #ifdef PROVIDE_STABLE case STABLE_REP: - asmInstr(bco,i_UNPACK_STABLE); + emit_i0(bco,i_UNPACK_STABLE); break; #endif default: @@ -747,35 +985,35 @@ void asmReturnUnboxed( AsmBCO bco, AsmRep rep ) { switch (rep) { case CHAR_REP: - asmInstr(bco,i_RETURN_CHAR); + emit_i0(bco,i_RETURN_CHAR); break; case INT_REP: - asmInstr(bco,i_RETURN_INT); + emit_i0(bco,i_RETURN_INT); break; #ifdef PROVIDE_INT64 case INT64_REP: - asmInstr(bco,i_RETURN_INT64); + emit_i0(bco,i_RETURN_INT64); break; #endif #ifdef PROVIDE_WORD case WORD_REP: - asmInstr(bco,i_RETURN_WORD); + emit_i0(bco,i_RETURN_WORD); break; #endif #ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_RETURN_ADDR); + emit_i0(bco,i_RETURN_ADDR); break; #endif case FLOAT_REP: - asmInstr(bco,i_RETURN_FLOAT); + emit_i0(bco,i_RETURN_FLOAT); break; case DOUBLE_REP: - asmInstr(bco,i_RETURN_DOUBLE); + emit_i0(bco,i_RETURN_DOUBLE); break; #ifdef PROVIDE_STABLE case STABLE_REP: - asmInstr(bco,i_RETURN_STABLE); + emit_i0(bco,i_RETURN_STABLE); break; #endif #ifdef PROVIDE_INTEGER @@ -798,7 +1036,7 @@ void asmReturnUnboxed( AsmBCO bco, AsmRep rep ) case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ #endif - asmInstr(bco,i_RETURN_GENERIC); + emit_i0(bco,i_RETURN_GENERIC); break; default: barf("asmReturnUnboxed %d",rep); @@ -811,8 +1049,7 @@ void asmReturnUnboxed( AsmBCO bco, AsmRep rep ) void asmConstInt( AsmBCO bco, AsmInt x ) { - asmInstr(bco,i_CONST_INT); - asmInstr(bco,bco->nps.len); + emit_i_CONST_INT(bco,bco->nps.len); asmWords(bco,AsmInt,x); bco->sp += repSizeW(INT_REP); } @@ -820,8 +1057,7 @@ void asmConstInt( AsmBCO bco, AsmInt x ) #ifdef PROVIDE_INT64 void asmConstInt64( AsmBCO bco, AsmInt64 x ) { - asmInstr(bco,i_CONST_INT64); - asmInstr(bco,bco->nps.len); + emit_i_CONST_INT64(bco,bco->nps.len); asmWords(bco,AsmInt64,x); bco->sp += repSizeW(INT64_REP); } @@ -830,8 +1066,7 @@ void asmConstInt64( AsmBCO bco, AsmInt64 x ) #ifdef PROVIDE_INTEGER void asmConstInteger( AsmBCO bco, AsmString x ) { - asmInstr(bco,i_CONST_INTEGER); - asmInstr(bco,bco->nps.len); + emit_i_CONST_INTEGER(bco,bco->nps.len); asmWords(bco,AsmString,x); bco->sp += repSizeW(INTEGER_REP); } @@ -840,8 +1075,7 @@ void asmConstInteger( AsmBCO bco, AsmString x ) #ifdef PROVIDE_ADDR void asmConstAddr( AsmBCO bco, AsmAddr x ) { - asmInstr(bco,i_CONST_ADDR); - asmInstr(bco,bco->nps.len); + emit_i_CONST_ADDR(bco,bco->nps.len); asmWords(bco,AsmAddr,x); bco->sp += repSizeW(ADDR_REP); } @@ -850,8 +1084,7 @@ void asmConstAddr( AsmBCO bco, AsmAddr x ) #ifdef PROVIDE_WORD void asmConstWord( AsmBCO bco, AsmWord x ) { - asmInstr(bco,i_CONST_INT); - asmInstr(bco,bco->nps.len); + emit_i_CONST_INT(bco->nps.len); asmWords(bco,AsmWord,x); bco->sp += repSizeW(WORD_REP); } @@ -859,30 +1092,27 @@ void asmConstWord( AsmBCO bco, AsmWord x ) void asmConstChar( AsmBCO bco, AsmChar x ) { - asmInstr(bco,i_CONST_CHAR); - asmInstr(bco,bco->nps.len); + emit_i_CONST_CHAR(bco,bco->nps.len); asmWords(bco,AsmChar,x); bco->sp += repSizeW(CHAR_REP); } void asmConstFloat( AsmBCO bco, AsmFloat x ) { - asmInstr(bco,i_CONST_FLOAT); - asmInstr(bco,bco->nps.len); + emit_i_CONST_FLOAT(bco,bco->nps.len); asmWords(bco,AsmFloat,x); bco->sp += repSizeW(FLOAT_REP); } void asmConstDouble( AsmBCO bco, AsmDouble x ) { - asmInstr(bco,i_CONST_DOUBLE); - asmInstr(bco,bco->nps.len); + emit_i_CONST_DOUBLE(bco,bco->nps.len); asmWords(bco,AsmDouble,x); bco->sp += repSizeW(DOUBLE_REP); } /* -------------------------------------------------------------------------- - * + * Algebraic case helpers * ------------------------------------------------------------------------*/ /* a mildly bogus pair of functions... */ @@ -897,8 +1127,7 @@ void asmEndCase( AsmBCO bco ) AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr ) { - asmInstr(bco,i_RETADDR); - asmInstr(bco,bco->object.ptrs.len); + emit_i_RETADDR(bco,bco->object.ptrs.len); asmPtr(bco,&(ret_addr->object)); bco->sp += 2 * sizeofW(StgPtr); return bco->sp; @@ -939,9 +1168,9 @@ void asmEndAlt( AsmBCO bco, AsmSp sp ) AsmPc asmTest( AsmBCO bco, AsmWord tag ) { - asmInstr(bco,i_TEST); - asmInstr(bco,tag); - asmInstr(bco,0); + asmInstr8(bco,i_TEST); + asmInstr8(bco,tag); + asmInstr16(bco,0); return bco->is.len; } @@ -949,8 +1178,8 @@ AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x ) { asmVar(bco,v,INT_REP); asmConstInt(bco,x); - asmInstr(bco,i_TEST_INT); - asmInstr(bco,0); + asmInstr8(bco,i_TEST_INT); + asmInstr16(bco,0); bco->sp -= 2*repSizeW(INT_REP); return bco->is.len; } @@ -959,12 +1188,14 @@ void asmFixBranch( AsmBCO bco, AsmPc from ) { int distance = bco->is.len - from; ASSERT(distance >= 0); - setInstrs(&(bco->is),from-1,distance); + ASSERT(distance < 65536); + setInstrs(&(bco->is),from-2,distance/256); + setInstrs(&(bco->is),from-1,distance%256); } void asmPanic( AsmBCO bco ) { - asmInstr(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */ + emit_i0(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */ } /* -------------------------------------------------------------------------- @@ -978,8 +1209,7 @@ AsmSp asmBeginPrim( AsmBCO bco ) void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base ) { - asmInstr(bco,prim->prefix); - asmInstr(bco,prim->opcode); + emit_i1(bco,prim->prefix,prim->opcode); bco->sp = base; } @@ -1421,10 +1651,10 @@ const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) AsmBCO asm_BCO_catch ( void ) { AsmBCO bco = asmBeginBCO(0 /*NIL*/); - asmInstr(bco,i_ARG_CHECK); asmInstr(bco,2); - asmInstr(bco,i_PRIMOP1); asmInstr(bco,i_pushcatchframe); + emit_i1(bco,i_ARG_CHECK,2); + emit_i1(bco,i_PRIMOP1,i_pushcatchframe); bco->sp += (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame); - asmInstr(bco,i_ENTER); + emit_i0(bco,i_ENTER); asmEndBCO(bco); return bco; } @@ -1432,8 +1662,8 @@ AsmBCO asm_BCO_catch ( void ) AsmBCO asm_BCO_raise ( void ) { AsmBCO bco = asmBeginBCO(0 /*NIL*/); - asmInstr(bco,i_ARG_CHECK); asmInstr(bco,1); - asmInstr(bco,i_PRIMOP2); asmInstr(bco,i_raise); + emit_i1(bco,i_ARG_CHECK,1); + emit_i1(bco,i_PRIMOP2,i_raise); asmEndBCO(bco); return bco; } @@ -1443,22 +1673,21 @@ AsmBCO asm_BCO_seq ( void ) AsmBCO eval, cont; cont = asmBeginBCO(0 /*NIL*/); - asmInstr(cont,i_ARG_CHECK); asmInstr(cont,2); - asmInstr(cont,i_VAR); asmInstr(cont,1); - asmInstr(cont,i_SLIDE); asmInstr(cont,1); asmInstr(cont,2); - asmInstr(cont,i_ENTER); + emit_i1(cont,i_ARG_CHECK,2); + emit_i_VAR(cont,1); + emit_i_SLIDE(cont,1,2); + emit_i0(cont,i_ENTER); cont->sp += 3*sizeofW(StgPtr); asmEndBCO(cont); eval = asmBeginBCO(0 /*NIL*/); - asmInstr(eval,i_ARG_CHECK); asmInstr(eval,2); - asmInstr(eval,i_RETADDR); - asmInstr(eval,eval->object.ptrs.len); + emit_i1(eval,i_ARG_CHECK,2); + emit_i_RETADDR(eval,eval->object.ptrs.len); asmPtr(eval,&(cont->object)); - asmInstr(eval,i_VAR); asmInstr(eval,2); - asmInstr(eval,i_SLIDE); asmInstr(eval,3); asmInstr(eval,1); - asmInstr(eval,i_PRIMOP1); asmInstr(eval,i_pushseqframe); - asmInstr(eval,i_ENTER); + emit_i_VAR(eval,2); + emit_i_SLIDE(eval,3,1); + emit_i1(eval,i_PRIMOP1,i_pushseqframe); + emit_i0(eval,i_ENTER); eval->sp += sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr); asmEndBCO(eval); @@ -1472,8 +1701,7 @@ AsmBCO asm_BCO_seq ( void ) AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info ) { ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - asmInstr(bco,i_ALLOC_CONSTR); - asmInstr(bco,bco->nps.len); + emit_i1(bco,i_ALLOC_CONSTR,bco->nps.len); asmWords(bco,AsmInfo,info); bco->sp += sizeofW(StgClosurePtr); grabHpNonUpd(bco,sizeW_fromITBL(info)); @@ -1492,8 +1720,7 @@ void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info ) assert(start >= v); /* only reason to include info is for this assertion */ assert(info->layout.payload.ptrs == size); - asmInstr(bco,i_PACK); - asmInstr(bco,bco->sp - v); + emit_i1(bco,i_PACK,bco->sp - v); bco->sp = start; } @@ -1504,13 +1731,12 @@ void asmBeginUnpack( AsmBCO bco ) void asmEndUnpack( AsmBCO bco ) { - asmInstr(bco,i_UNPACK); + emit_i0(bco,i_UNPACK); } AsmVar asmAllocAP( AsmBCO bco, AsmNat words ) { - asmInstr(bco,i_ALLOC_AP); - asmInstr(bco,words); + emit_i1(bco,i_ALLOC_AP,words); bco->sp += sizeofW(StgPtr); grabHpUpd(bco,AP_sizeW(words)); return bco->sp; @@ -1523,16 +1749,14 @@ AsmSp asmBeginMkAP( AsmBCO bco ) void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start ) { - asmInstr(bco,i_MKAP); - asmInstr(bco,bco->sp-v); - asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */ + emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1); + /* -1 because fun isn't counted */ bco->sp = start; } AsmVar asmAllocPAP( AsmBCO bco, AsmNat size ) { - asmInstr(bco,i_ALLOC_PAP); - asmInstr(bco,size); + emit_i1(bco,i_ALLOC_PAP,size); bco->sp += sizeofW(StgPtr); return bco->sp; } @@ -1544,25 +1768,15 @@ AsmSp asmBeginMkPAP( AsmBCO bco ) void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start ) { - asmInstr(bco,i_MKPAP); - asmInstr(bco,bco->sp-v); - asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */ + emit_i2(bco,i_MKPAP,bco->sp-v,bco->sp-start-1); + /* -1 because fun isn't counted */ bco->sp = start; } AsmVar asmClosure( AsmBCO bco, AsmObject p ) { - StgWord o = bco->object.ptrs.len; - if (o < 256) { - asmInstr(bco,i_CONST); - asmInstr(bco,o); - asmPtr(bco,p); - } else { - asmInstr(bco,i_CONST2); - asmInstr(bco,o / 256); - asmInstr(bco,o % 256); - asmPtr(bco,p); - } + emit_i_CONST(bco,bco->object.ptrs.len); + asmPtr(bco,p); bco->sp += sizeofW(StgPtr); return bco->sp; } diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index dea89e0..3522072 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Bytecodes.h,v 1.4 1999/03/01 14:47:07 sewardj Exp $ + * $Id: Bytecodes.h,v 1.5 1999/03/09 14:51:24 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -29,7 +29,6 @@ typedef enum , i_PANIC /* irrefutable pattern match failed! */ , i_STK_CHECK - , i_HP_CHECK , i_ARG_CHECK @@ -37,26 +36,32 @@ typedef enum , 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_CONST2 /* 16 bit offsets - ad-hoc fix for general problem */ + , 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 @@ -71,6 +76,7 @@ typedef enum #endif #ifdef PROVIDE_INTEGER , i_CONST_INTEGER + , i_CONST_INTEGER_big #endif #ifdef PROVIDE_WORD , i_VAR_WORD @@ -81,25 +87,33 @@ typedef enum #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 diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index 63de39d..c1f29ee 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Disassembler.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:47:05 $ + * $Revision: 1.5 $ + * $Date: 1999/03/09 14:51:23 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -46,6 +46,14 @@ static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disInt16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgInt x = bcoInstr16(bco,pc); pc+=2; + ASSERT(pc < bco->n_instrs); + fprintf(stderr,"%s %d",i,x); + return pc; +} + static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i ) { StgInt x = bcoInstr(bco,pc++); @@ -54,17 +62,28 @@ static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disIntInt16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgInt x, y; + x = bcoInstr16(bco,pc); pc += 2; + y = bcoInstr16(bco,pc); pc += 2; + fprintf(stderr,"%s %d %d",i,x,y); + return pc; +} + static InstrPtr disIntPC ( StgBCO *bco, InstrPtr pc, char* i ) { - StgInt x = bcoInstr(bco,pc++); - StgWord y = bcoInstr(bco,pc++); + StgInt x; + StgWord y; + x = bcoInstr(bco,pc++); + y = bcoInstr16(bco,pc); pc += 2; fprintf(stderr,"%s %d %d",i,x,pc+y); return pc; } static InstrPtr disPC ( StgBCO *bco, InstrPtr pc, char* i ) { - StgWord y = bcoInstr(bco,pc++); + StgWord y = bcoInstr16(bco,pc); pc += 2; fprintf(stderr,"%s %d",i,pc+y); return pc; } @@ -87,12 +106,12 @@ static InstrPtr disConstPtr ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } -static InstrPtr disConst2Ptr ( StgBCO *bco, InstrPtr pc, char* i ) +static InstrPtr disConstPtr16 ( StgBCO *bco, InstrPtr pc, char* i ) { - StgWord o1 = bcoInstr(bco,pc++); - StgWord o2 = bcoInstr(bco,pc++); - StgWord o = o1*256 + o2; - StgPtr x = bcoConstPtr(bco,o); + StgInt o; + StgPtr x; + o = bcoInstr16(bco,pc); pc += 2; + x = bcoConstPtr(bco,o); fprintf(stderr,"%s [%d]=",i,o); printPtr(x); /* bad way to print it... */ return pc; @@ -105,6 +124,13 @@ static InstrPtr disConstInt ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disConstInt16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgInt x = bcoConstInt(bco,bcoInstr16(bco,pc)); pc += 2; + fprintf(stderr,"%s %d",i,x); + return pc; +} + static InstrPtr disConstAddr ( StgBCO *bco, InstrPtr pc, char* i ) { StgAddr x = bcoConstAddr(bco,bcoInstr(bco,pc++)); @@ -113,6 +139,14 @@ static InstrPtr disConstAddr ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disConstAddr16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgAddr x = bcoConstAddr(bco,bcoInstr16(bco,pc)); pc += 2; + fprintf(stderr,"%s ",i); + printPtr(x); + return pc; +} + static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i ) { StgChar x = bcoConstChar(bco,bcoInstr(bco,pc++)); @@ -122,6 +156,15 @@ static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disConstChar16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgChar x = bcoConstChar(bco,bcoInstr16(bco,pc)); pc += 2; + if (isprint((int)x)) + fprintf(stderr,"%s '%c'",i,x); else + fprintf(stderr,"%s 0x%x",i,(int)x); + return pc; +} + static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i ) { StgFloat x = bcoConstFloat(bco,bcoInstr(bco,pc++)); @@ -129,6 +172,13 @@ static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disConstFloat16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgFloat x = bcoConstFloat(bco,bcoInstr16(bco,pc)); pc += 2; + fprintf(stderr,"%s %f",i,x); + return pc; +} + static InstrPtr disConstDouble ( StgBCO *bco, InstrPtr pc, char* i ) { StgDouble x = bcoConstDouble(bco,bcoInstr(bco,pc++)); @@ -136,6 +186,13 @@ static InstrPtr disConstDouble ( StgBCO *bco, InstrPtr pc, char* i ) return pc; } +static InstrPtr disConstDouble16 ( StgBCO *bco, InstrPtr pc, char* i ) +{ + StgDouble x = bcoConstDouble(bco,bcoInstr16(bco,pc)); pc += 2; + fprintf(stderr,"%s %f",i,x); + return pc; +} + InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) { Instr in; @@ -146,8 +203,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disNone(bco,pc,"INTERNAL_ERROR"); case i_PANIC: return disNone(bco,pc,"PANIC"); - case i_HP_CHECK: - return disInt(bco,pc,"HP_CHECK"); case i_STK_CHECK: return disInt(bco,pc,"STK_CHECK"); case i_ARG_CHECK: @@ -160,26 +215,34 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) return disInfo(bco,pc,"ALLOC_CONSTR"); case i_MKAP: return disIntInt(bco,pc,"MKAP"); + case i_MKAP_big: + return disIntInt16(bco,pc,"MKAP_big"); case i_MKPAP: return disIntInt(bco,pc,"MKPAP"); case i_PACK: return disInt(bco,pc,"PACK"); case i_SLIDE: return disIntInt(bco,pc,"SLIDE"); + case i_SLIDE_big: + return disIntInt16(bco,pc,"SLIDE_big"); case i_ENTER: return disNone(bco,pc,"ENTER"); case i_RETADDR: return disConstPtr(bco,pc,"RETADDR"); + case i_RETADDR_big: + return disConstPtr16(bco,pc,"RETADDR_big"); case i_TEST: return disIntPC(bco,pc,"TEST"); case i_UNPACK: return disNone(bco,pc,"UNPACK"); case i_VAR: return disInt(bco,pc,"VAR"); + case i_VAR_big: + return disInt16(bco,pc,"VAR_big"); case i_CONST: return disConstPtr(bco,pc,"CONST"); - case i_CONST2: - return disConst2Ptr(bco,pc,"CONST2"); + case i_CONST_big: + return disConstPtr16(bco,pc,"CONST_big"); case i_VOID: return disNone(bco,pc,"VOID"); @@ -188,8 +251,12 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_VAR_INT: return disInt(bco,pc,"VAR_INT"); + case i_VAR_INT_big: + return disInt16(bco,pc,"VAR_INT_big"); case i_CONST_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: @@ -214,6 +281,8 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) #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: @@ -230,8 +299,12 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) #ifdef PROVIDE_ADDR case i_VAR_ADDR: return disInt(bco,pc,"VAR_ADDR"); + case i_VAR_ADDR_big: + return disInt16(bco,pc,"VAR_ADDR_big"); case i_CONST_ADDR: 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: @@ -241,8 +314,12 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) #endif case i_VAR_CHAR: return disInt(bco,pc,"VAR_CHAR"); + case i_VAR_CHAR_big: + return disInt16(bco,pc,"VAR_CHAR_big"); case i_CONST_CHAR: 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: @@ -252,8 +329,12 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_VAR_FLOAT: return disInt(bco,pc,"VAR_FLOAT"); + case i_VAR_FLOAT_big: + return disInt16(bco,pc,"VAR_FLOAT_big"); case i_CONST_FLOAT: 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: @@ -263,8 +344,12 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_VAR_DOUBLE: return disInt(bco,pc,"VAR_DOUBLE"); + case i_VAR_DOUBLE_big: + return disInt16(bco,pc,"VAR_DOUBLE_big"); case i_CONST_DOUBLE: 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: @@ -345,7 +430,7 @@ void disassemble( StgBCO *bco, char* prefix ) fprintf(stderr, "\n"); } else - fprintf(stderr, "\t(handwritten bytecode)\n" ); + fprintf(stderr, "\t(no associated tree)\n" ); } #endif /* INTERPRETER */ diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 822b52d..5a6b0bc 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.10 $ - * $Date: 1999/03/01 14:47:03 $ + * $Revision: 1.11 $ + * $Date: 1999/03/09 14:51:21 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -104,10 +104,10 @@ void defaultsHook (void) * ------------------------------------------------------------------------*/ #ifdef PROVIDE_INTEGER -static /*inline*/ mpz_ptr mpz_alloc ( void ); -//static /*inline*/ void mpz_free ( mpz_ptr ); +static inline mpz_ptr mpz_alloc ( void ); +//static inline void mpz_free ( mpz_ptr ); -static /*inline*/ mpz_ptr mpz_alloc ( void ) +static inline mpz_ptr mpz_alloc ( void ) { mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc")); mpz_init(r); @@ -115,7 +115,7 @@ static /*inline*/ mpz_ptr mpz_alloc ( void ) } #if 0 /* apparently unused */ -static /*inline*/ void mpz_free ( mpz_ptr a ) +static inline void mpz_free ( mpz_ptr a ) { mpz_clear(a); free(a); @@ -127,71 +127,71 @@ static /*inline*/ void mpz_free ( mpz_ptr a ) * * ------------------------------------------------------------------------*/ -/*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 ); +/*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 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 ); +/*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 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 ); -/*static*/ /*inline*/ void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; } +/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; } -/*static*/ /*inline*/ void PushTaggedRealWorld( void ); -/*static*/ /*inline*/ void PushTaggedInt ( StgInt x ); +/*static*/ inline void PushTaggedRealWorld( void ); +/*static*/ inline void PushTaggedInt ( StgInt x ); #ifdef PROVIDE_INT64 -/*static*/ /*inline*/ void PushTaggedInt64 ( StgInt64 x ); +/*static*/ inline void PushTaggedInt64 ( StgInt64 x ); #endif #ifdef PROVIDE_INTEGER -/*static*/ /*inline*/ void PushTaggedInteger ( mpz_ptr x ); +/*static*/ inline void PushTaggedInteger ( mpz_ptr x ); #endif #ifdef PROVIDE_WORD -/*static*/ /*inline*/ void PushTaggedWord ( StgWord x ); +/*static*/ inline void PushTaggedWord ( StgWord x ); #endif #ifdef PROVIDE_ADDR -/*static*/ /*inline*/ void PushTaggedAddr ( StgAddr x ); +/*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 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); } +/*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); } +/*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 ) +/*static*/ inline void PushTaggedInteger ( mpz_ptr x ) { StgForeignObj *result; //StgWeak *w; @@ -215,89 +215,89 @@ static /*inline*/ void mpz_free ( mpz_ptr a ) } #endif #ifdef PROVIDE_WORD -/*static*/ /*inline*/ void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } +/*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); } +/*static*/ inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } #endif -/*static*/ /*inline*/ void PushTaggedChar ( StgChar x ) +/*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 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 ); +/*static*/ inline void PopTaggedRealWorld ( void ); +/*static*/ inline StgInt PopTaggedInt ( void ); #ifdef PROVIDE_INT64 -/*static*/ /*inline*/ StgInt64 PopTaggedInt64 ( void ); +/*static*/ inline StgInt64 PopTaggedInt64 ( void ); #endif #ifdef PROVIDE_INTEGER -/*static*/ /*inline*/ mpz_ptr PopTaggedInteger ( void ); +/*static*/ inline mpz_ptr PopTaggedInteger ( void ); #endif #ifdef PROVIDE_WORD -/*static*/ /*inline*/ StgWord PopTaggedWord ( void ); +/*static*/ inline StgWord PopTaggedWord ( void ); #endif #ifdef PROVIDE_ADDR -/*static*/ /*inline*/ StgAddr PopTaggedAddr ( void ); +/*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 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;} +/*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;} +/*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);} +/*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;} +/*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;} +/*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 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 ); +/*static*/ inline StgInt taggedStackInt ( StgStackOffset i ); #ifdef PROVIDE_INT64 -/*static*/ /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i ); +/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i ); #endif #ifdef PROVIDE_WORD -/*static*/ /*inline*/ StgWord taggedStackWord ( StgStackOffset i ); +/*static*/ inline StgWord taggedStackWord ( StgStackOffset i ); #endif #ifdef PROVIDE_ADDR -/*static*/ /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i ); +/*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 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); } +/*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); } +/*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); } +/*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); } +/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); } #endif -/*static*/ /*inline*/ StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(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); } +/*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); } /* -------------------------------------------------------------------------- @@ -312,13 +312,13 @@ static /*inline*/ void mpz_free ( mpz_ptr a ) * (array ops, gmp ops, etc) * ------------------------------------------------------------------------*/ -static /*inline*/ StgPtr grabHpUpd( nat size ) +static inline StgPtr grabHpUpd( nat size ) { ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); return allocate(size); } -static /*inline*/ StgPtr grabHpNonUpd( nat size ) +static inline StgPtr grabHpNonUpd( nat size ) { ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); return allocate(size); @@ -332,15 +332,15 @@ static /*inline*/ StgPtr grabHpNonUpd( nat size ) * o Stop frames * ------------------------------------------------------------------------*/ -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 ); +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 ); -static /*inline*/ StgClosure* raiseAnError ( StgClosure* errObj ); +static inline StgClosure* raiseAnError ( StgClosure* errObj ); -static /*inline*/ void PopUpdateFrame( StgClosure* obj ) +static inline void PopUpdateFrame( StgClosure* obj ) { /* NB: doesn't assume that Sp == Su */ IF_DEBUG(evaluator, @@ -360,7 +360,7 @@ static /*inline*/ void PopUpdateFrame( StgClosure* obj ) Su = Su->link; } -static /*inline*/ void PopStopFrame( StgClosure* obj ) +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. @@ -369,7 +369,7 @@ static /*inline*/ void PopStopFrame( StgClosure* obj ) *stgCast(StgClosure**,Sp) = obj; } -static /*inline*/ void PushCatchFrame( StgClosure* handler ) +static inline void PushCatchFrame( StgClosure* handler ) { StgCatchFrame* fp; /* ToDo: stack check! */ @@ -381,7 +381,7 @@ static /*inline*/ void PushCatchFrame( StgClosure* handler ) Su = stgCast(StgUpdateFrame*,fp); } -static /*inline*/ void PopCatchFrame( void ) +static inline void PopCatchFrame( void ) { /* NB: doesn't assume that Sp == Su */ /* fprintf(stderr,"Popping catch frame\n"); */ @@ -389,7 +389,7 @@ static /*inline*/ void PopCatchFrame( void ) Su = stgCast(StgCatchFrame*,Su)->link; } -static /*inline*/ void PushSeqFrame( void ) +static inline void PushSeqFrame( void ) { StgSeqFrame* fp; /* ToDo: stack check! */ @@ -400,14 +400,14 @@ static /*inline*/ void PushSeqFrame( void ) Su = stgCast(StgUpdateFrame*,fp); } -static /*inline*/ void PopSeqFrame( void ) +static inline void PopSeqFrame( void ) { /* NB: doesn't assume that Sp == Su */ Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame); Su = stgCast(StgSeqFrame*,Su)->link; } -static /*inline*/ StgClosure* raiseAnError( StgClosure* errObj ) +static inline StgClosure* raiseAnError( StgClosure* errObj ) { StgClosure *raise_closure; @@ -1046,6 +1046,41 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); #endif /* PROVIDE_ARRAY */ +static int enterCountI = 0; + +void myStackCheck ( void ) +{ + StgPtr sp = Sp; + StgPtr su = Su; + //fprintf(stderr, "myStackCheck\n"); + if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) { + fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" ); + assert(0); + } + while (1) { + if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) { + fprintf ( stderr, "myStackCheck: su out of stack\n" ); + assert(0); + } + switch (get_itbl(stgCast(StgClosure*,su))->type) { + case CATCH_FRAME: + su = ((StgCatchFrame*)(su))->link; + break; + case UPDATE_FRAME: + su = ((StgUpdateFrame*)(su))->link; + break; + case SEQ_FRAME: + su = ((StgSeqFrame*)(su))->link; + break; + case STOP_FRAME: + goto postloop; + default: + fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0); + } + } + postloop: +} + /* This is written as one giant function in the hope that gcc will do * a better job of register allocation. @@ -1056,43 +1091,26 @@ StgThreadReturnCode enter( StgClosure* obj ) * iterations. */ char enterCount = 0; - int enterCountI = 0; + //fprintf ( stderr, "enter: Sp=%p Su=%p\n", Sp, Su); enterLoop: - /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */ + enterCountI++;// fprintf(stderr, "%d\n", enterCountI); ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su)); + #if DEBUG - IF_DEBUG(evaluator, + IF_DEBUG(evaluator, fprintf(stderr, "\n---------------------------------------------------------------\n"); - fprintf(stderr,"(%d) Entering: ",enterCountI++); printObj(obj); + 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 0 - IF_DEBUG(sanity, - { - /*belch("Starting sanity check"); - *SaveThreadState(); - *checkTSO(CurrentTSO, heap_step); - * This check fails if we've done any updates because we - * whack into holes in the heap. - *checkHeap(?,?); - *belch("Ending sanity check"); - */ - } - ); -#endif -#if 0 - IF_DEBUG(evaluator, - fprintf(stderr,"Continue?\n"); - getchar() - ); + ); #endif + if (++enterCount == 0 && context_switch) { PushCPtr(obj); /* code to restart with */ + assert(0); return ThreadYielding; } switch ( get_itbl(obj)->type ) { @@ -1102,19 +1120,14 @@ enterLoop: { StgBCO* bco = stgCast(StgBCO*,obj); InstrPtr pc = 0; -#if 1 /* We don't use an explicit HP_CHECK anymore */ + if (doYouWantToGC()) { PushCPtr(obj); /* code to restart with */ return HeapOverflow; } -#endif + while (1) { ASSERT(pc < bco->n_instrs); - if (0 /*enterCountI > 2*/ ) { - fprintf(stderr, "\n\n-----------------\n" ); - printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su); - fprintf(stderr, "\n"); - } IF_DEBUG(evaluator, fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc); disInstr(bco,pc); @@ -1126,20 +1139,6 @@ enterLoop: barf("INTERNAL_ERROR at %p:%d",bco,pc-1); case i_PANIC: barf("PANIC at %p:%d",bco,pc-1); -#if 0 - case i_HP_CHECK: - { - int n = bcoInstr(bco,pc++); - /* ToDo: we could allocate the whole thing now and - * slice it up ourselves - */ - if (doYouWantToGC()) { - PushCPtr(obj); /* code to restart with */ - return HeapOverflow; - } - break; - } -#endif case i_STK_CHECK: { int n = bcoInstr(bco,pc++); @@ -1275,6 +1274,25 @@ enterLoop: ); 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++); @@ -1324,6 +1342,19 @@ enterLoop: 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(); @@ -1338,7 +1369,7 @@ enterLoop: case i_TEST: { int tag = bcoInstr(bco,pc++); - StgWord offset = bcoInstr(bco,pc++); + StgWord offset = bcoInstr16(bco,pc); pc += 2; if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) { pc += offset; } @@ -1358,6 +1389,11 @@ enterLoop: } break; } + case i_VAR_big: + { + PushPtr(stackPtr(bcoInstr16(bco,pc))); pc+=2; + break; + } case i_VAR: { PushPtr(stackPtr(bcoInstr(bco,pc++))); @@ -1368,12 +1404,9 @@ enterLoop: PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++)))); break; } - case i_CONST2: + case i_CONST_big: { - StgWord o1 = bcoInstr(bco,pc++); - StgWord o2 = bcoInstr(bco,pc++); - StgWord o = o1*256 + o2; - PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o))); + PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr16(bco,pc)))); pc += 2; break; } case i_VOID: @@ -1417,9 +1450,10 @@ enterLoop: } case i_TEST_INT: { - StgWord offset = bcoInstr(bco,pc++); + StgWord offset = bcoInstr16(bco,pc); StgInt x = PopTaggedInt(); StgInt y = PopTaggedInt(); + pc += 2; if (x != y) { pc += offset; } @@ -2073,7 +2107,9 @@ enterLoop: break; #endif /* PROVIDE_INT64 */ #ifdef PROVIDE_INTEGER - case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break; + 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; #endif case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break; @@ -2149,7 +2185,9 @@ enterLoop: break; #endif /* PROVIDE_INT64 */ #ifdef PROVIDE_INTEGER - case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break; + 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; @@ -2585,7 +2623,10 @@ off the stack. break; } default: - barf("Unrecognised instruction"); + pc--; + printf ( "\n\n" ); + disInstr ( bco, pc ); + barf("\nUnrecognised instruction"); } } barf("Ran off the end of bco - yoiks"); @@ -2593,24 +2634,24 @@ off the stack. } case CAF_UNENTERED: { - StgCAF* caf = stgCast(StgCAF*,obj); + 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 */ - { - /*was StgBlackHole* */ - StgBlockingQueue* bh - = stgCast(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 = stgCast(StgClosure*,bh); - PUSH_UPD_FRAME(bh,0); - Sp -= sizeofW(StgUpdateFrame); - } + /* 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; @@ -2618,7 +2659,7 @@ off the stack. } case CAF_ENTERED: { - StgCAF* caf = stgCast(StgCAF*,obj); + StgCAF* caf = (StgCAF*)obj; obj = caf->value; /* it's just a fancy indirection */ goto enterLoop; } @@ -2626,11 +2667,12 @@ off the stack. case CAF_BLACKHOLE: { /*was StgBlackHole* */ - StgBlockingQueue* bh = stgCast(StgBlockingQueue*,obj); + 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: @@ -2641,7 +2683,8 @@ off the stack. PushCPtr(obj); /* code to restart with */ return StackOverflow; } - /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */ + /* 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) { @@ -2678,6 +2721,11 @@ off the stack. 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: @@ -2731,12 +2779,19 @@ off the stack. } 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); } /* ----------------------------------------------------------------------------- diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c index 28fa132..48fed99 100644 --- a/ghc/rts/Printer.c +++ b/ghc/rts/Printer.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Printer.c,v 1.8 1999/03/03 19:16:29 sof Exp $ + * $Id: Printer.c,v 1.9 1999/03/09 14:51:23 sewardj Exp $ * * Copyright (c) 1994-1999. * @@ -39,7 +39,7 @@ static void printZcoded ( const char *raw ); * Printer * ------------------------------------------------------------------------*/ -#ifdef INTERPRETER + extern void* itblNames[]; extern int nItblNames; char* lookupHugsItblName ( void* v ) @@ -49,7 +49,6 @@ char* lookupHugsItblName ( void* v ) if (itblNames[i] == v) return itblNames[i+1]; return NULL; } -#endif extern void printPtr( StgPtr p ) { @@ -60,9 +59,9 @@ extern void printPtr( StgPtr p ) #ifdef INTERPRETER } else if ((raw = lookupHugsName(p)) != 0) { fprintf(stderr, "%s", raw); +#endif } else if ((str = lookupHugsItblName(p)) != 0) { fprintf(stderr, "%p=%s", p, str); -#endif } else { fprintf(stderr, "%p", p); } @@ -349,12 +348,10 @@ StgPtr printStackObj( StgPtr sp ) } else { StgClosure* c = (StgClosure*)(*sp); printPtr((StgPtr)*sp); -#ifdef INTERPRETER if (c == &ret_bco_info) { fprintf(stderr, "\t\t"); fprintf(stderr, "ret_bco_info\n" ); } else -#endif if (IS_HUGS_CONSTR_INFO(GET_INFO(c))) { fprintf(stderr, "\t\t\t"); fprintf(stderr, "ConstrInfoTable\n" ); @@ -380,7 +377,7 @@ void printStackChunk( StgPtr sp, StgPtr spBottom ) ASSERT(sp <= spBottom); while (sp < spBottom) { - if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO((void*)*sp)) { + if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO(*sp)) { info = get_itbl((StgClosure *)sp); switch (info->type) { @@ -736,7 +733,6 @@ extern void DEBUG_LoadSymbols( char *name ) bfd* abfd; char **matching; -#ifndef _WIN32 bfd_init(); abfd = bfd_openr(name, "default"); if (abfd == NULL) { @@ -745,7 +741,6 @@ extern void DEBUG_LoadSymbols( char *name ) if (!bfd_check_format_matches (abfd, bfd_object, &matching)) { barf("mismatch"); } -#endif { long storage_needed; -- 1.7.10.4