1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
3 * This is the Hugs compiler, handling translation of typechecked code to
4 * `kernel' language, elimination of pattern matching and translation to
5 * super combinators (lambda lifting).
7 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
8 * All rights reserved. See NOTICE for details and conditions of use etc...
9 * Hugs version 1.4, December 1997
11 * $RCSfile: compiler.c,v $
13 * $Date: 1998/12/02 13:22:01 $
14 * ------------------------------------------------------------------------*/
21 #include "hugs.h" /* for target */
29 #include "Rts.h" /* for rts_eval and related stuff */
30 #include "RtsAPI.h" /* for rts_eval and related stuff */
32 Name currentName; /* Top level name being processed */
34 Bool debugCode = FALSE; /* TRUE => print G-code to screen */
37 /* --------------------------------------------------------------------------
38 * Local function prototypes:
39 * ------------------------------------------------------------------------*/
41 static List local addGlobals( List binds );
42 static Void local compileGlobalFunction Args((Pair));
43 static Void local compileGenFunction Args((Name));
44 static Name local compileSelFunction Args((Pair));
46 /* --------------------------------------------------------------------------
48 * ------------------------------------------------------------------------*/
51 #include "translate.h"
54 static Void local stgCGBinds( List );
56 static Void local stgCGBinds(binds)
61 /* --------------------------------------------------------------------------
62 * Main entry points to compiler:
63 * ------------------------------------------------------------------------*/
65 static List addGlobals( List binds )
67 /* stgGlobals = pieces of code generated for selectors, tuples, etc */
68 for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
69 StgVar bind = snd(hd(stgGlobals));
70 if (nonNull(stgVarBody(bind))) {
71 binds = cons(bind,binds);
78 /* This is a hack to see if "show [1..1000]" will go any faster if I
79 * code primShowInt in C
81 char* prim_showInt(int x)
84 sprintf(buffer,"%d",x);
88 void prim_flush_stdout(void)
94 Void evalExp() { /* compile and run input expression */
95 /* ToDo: this name (and other names generated during pattern match?)
96 * get inserted in the symbol table but never get removed.
98 Name n = newName(inventText());
99 StgVar v = mkStgVar(NIL,NIL);
102 stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr)));
104 stgCGBinds(addGlobals(singleton(v)));
107 /* Run thread (and any other runnable threads) */
109 /* Re-initialise the scheduler - ToDo: do I need this? */
112 HaskellObj result; /* ignored */
113 SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result);
116 case AllBlocked: /* I don't understand the distinction - ADR */
117 printf("{Deadlock}");
121 printf("{Interrupted}");
132 internal("evalExp: Unrecognised SchedulerStatus");
139 static List local addStgVar( List binds, Pair bind ); /* todo */
141 static List local addStgVar( List binds, Pair bind )
143 StgVar nv = mkStgVar(NIL,NIL);
144 Text t = textOf(fst(bind));
145 Name n = findName(t);
147 if (isNull(n)) { /* Lookup global name - the only way*/
148 n = newName(t); /* this (should be able to happen) */
149 } /* is with new global var introduced*/
150 /* after type check; e.g. remPat1 */
152 return cons(nv,binds);
156 Void compileDefns() { /* compile script definitions */
157 Target t = length(valDefns) + length(genDefns) + length(selDefns);
164 for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
166 StgVar nv = mkStgVar(NIL,NIL);
169 binds = cons(nv,binds);
171 for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
172 for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
175 StgVar nv = mkStgVar(NIL,NIL);
178 binds = cons(nv,binds);
183 setGoal("Compiling",t);
184 /* do valDefns before everything else so that all stgVar's get added. */
185 for (; nonNull(valDefns); valDefns=tl(valDefns)) {
186 hd(valDefns) = transBinds(hd(valDefns));
187 mapAccum(addStgVar,binds,hd(valDefns));
188 mapProc(compileGlobalFunction,hd(valDefns));
191 for (; nonNull(genDefns); genDefns=tl(genDefns)) {
192 compileGenFunction(hd(genDefns));
195 for (; nonNull(selDefns); selDefns=tl(selDefns)) {
196 mapOver(compileSelFunction,hd(selDefns));
200 /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
201 binds = addGlobals(binds);
202 #if USE_HUGS_OPTIMIZER
203 mapProc(optimiseBind,binds);
210 static Void local compileGlobalFunction(bind)
212 Name n = findName(textOf(fst(bind)));
213 List defs = snd(bind);
214 Int arity = length(fst(hd(defs)));
217 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
220 static Void local compileGenFunction(n) /* Produce code for internally */
221 Name n; { /* generated function */
222 List defs = name(n).defn;
223 Int arity = length(fst(hd(defs)));
226 mapProc(transAlt,defs);
227 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
231 static Name local compileSelFunction(p) /* Produce code for selector func */
232 Pair p; { /* Should be merged with genDefns, */
233 Name s = fst(p); /* but the name(_).defn field is */
234 List defs = snd(p); /* already used for other purposes */
235 Int arity = length(fst(hd(defs))); /* in selector functions. */
238 mapProc(transAlt,defs);
239 stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
243 /* --------------------------------------------------------------------------
245 * ------------------------------------------------------------------------*/
256 /*-------------------------------------------------------------------------*/