2 /* --------------------------------------------------------------------------
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
9 * $RCSfile: codegen.c,v $
11 * $Date: 1999/03/01 14:46:42 $
12 * ------------------------------------------------------------------------*/
19 #include "Assembler.h"
22 #include "Rts.h" /* IF_DEBUG */
25 /* --------------------------------------------------------------------------
26 * Local function prototypes:
27 * ------------------------------------------------------------------------*/
29 #define getPos(v) intOf(stgVarInfo(v))
30 #define setPos(v,sp) stgVarInfo(v) = mkInt(sp)
31 #define getObj(v) ptrOf(stgVarInfo(v))
32 #define setObj(v,obj) stgVarInfo(v) = mkPtr(obj)
34 #define repOf(x) charOf(stgVarRep(x))
36 static void cgBind ( AsmBCO bco, StgVar v );
37 static Void pushVar ( AsmBCO bco, StgVar v );
38 static Void pushAtom ( AsmBCO bco, StgAtom atom );
39 static Void alloc ( AsmBCO bco, StgRhs rhs );
40 static Void build ( AsmBCO bco, StgRhs rhs );
41 static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
43 static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
44 static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
45 //static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
46 static AsmBCO cgLambda ( StgExpr e );
47 static AsmBCO cgRhs ( StgRhs rhs );
48 static void beginTop ( StgVar v );
49 static void endTop ( StgVar v );
51 /* --------------------------------------------------------------------------
53 * ------------------------------------------------------------------------*/
55 static Bool varHasClosure( StgVar v )
57 return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
60 /* should be AsmClosure* */
61 void* closureOfVar( StgVar v )
63 return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
66 char* lookupHugsName( void* closure )
70 for( nm=NAMEMIN; nm<nameHw; ++nm ) {
71 StgVar v = name(nm).stgVar;
73 && isPtr(stgVarInfo(v))
75 && closureOfVar(v) == closure) {
76 return textToStr(name(nm).text);
82 /* called at the start of GC */
83 void markHugsObjects( void )
87 for( nm=NAMEMIN; nm<nameHw; ++nm ) {
88 StgVar v = name(nm).stgVar;
89 if (isStgVar(v) && isPtr(stgVarInfo(v))) {
90 asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
95 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
97 setPos(v,asmBind(bco,rep));
100 static void cgBind( AsmBCO bco, StgVar v )
102 cgBindRep(bco,v,repOf(v));
105 static Void pushVar( AsmBCO bco, StgVar v )
107 Cell info = stgVarInfo(v);
108 // if (!isStgVar(v)) {
109 //printf("\n\nprefail\n");
114 asmClosure(bco,ptrOf(info));
115 } else if (isInt(info)) {
116 asmVar(bco,intOf(info),repOf(v));
122 static Void pushAtom( AsmBCO bco, StgAtom e )
129 pushVar(bco,name(e).stgVar);
132 asmConstChar(bco,charOf(e));
135 asmConstInt(bco,intOf(e));
137 #if BIGNUM_IS_INTEGER
139 asmConstInteger(bco,bignumToString(e));
141 #elif BIGNUM_IS_INT64
143 asmConstInt64(bco,bignumOf(e));
146 #warning What is BIGNUM?
150 asmConstFloat(bco,e); /* ToDo: support both float and double! */
152 asmConstDouble(bco,floatOf(e));
157 asmConstDouble(bco,doubleOf(e));
161 #if USE_ADDR_FOR_STRINGS
162 asmConstAddr(bco,textToStr(textOf(e)));
164 asmClosure(bco,asmStringObj(textToStr(textOf(e))));
168 asmConstAddr(bco,ptrOf(e));
171 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
172 internal("pushAtom");
176 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
178 AsmBCO bco = asmBeginContinuation(sp,alts);
179 /* ppStgAlts(alts); */
180 for(; nonNull(alts); alts=tl(alts)) {
181 StgCaseAlt alt = hd(alts);
182 StgPat pat = stgCaseAltPat(alt);
183 StgExpr body = stgCaseAltBody(alt);
184 if (isDefaultPat(pat)) {
185 //AsmSp begin = asmBeginAlt(bco);
187 cgExpr(bco,root,body);
188 asmEndContinuation(bco);
189 return bco; /* ignore any further alternatives */
191 StgDiscr con = stgPatDiscr(pat);
192 List vs = stgPatVars(pat);
193 AsmSp begin = asmBeginAlt(bco);
194 AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
196 if (isBoxingCon(con)) {
197 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
200 map1Proc(cgBind,bco,reverse(vs));
203 cgExpr(bco,root,body);
204 asmEndAlt(bco,begin);
205 asmFixBranch(bco,fix);
208 /* if we got this far and didn't match, panic! */
210 asmEndContinuation(bco);
214 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
219 StgPrimPat pat = hd(pats);
220 if (isInt(stgVarBody(pat))) {
221 /* asmTestInt leaves stack unchanged - so no need to adjust it */
222 AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
223 assert(repOf(pat) == INT_REP);
224 testPrimPats(bco,root,tl(pats),e);
225 asmFixBranch(bco,tst);
227 testPrimPats(bco,root,tl(pats),e);
232 #if 0 /* appears to be unused */
233 static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
235 assert(0); /* ToDo: test for patterns */
236 map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
242 static AsmBCO cgLambda( StgExpr e )
244 AsmBCO bco = asmBeginBCO(e);
246 AsmSp root = asmBeginArgCheck(bco);
247 map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
248 asmEndArgCheck(bco,root);
251 cgExpr(bco,root,stgLambdaBody(e));
257 static AsmBCO cgRhs( StgRhs rhs )
259 AsmBCO bco = asmBeginBCO(rhs );
261 AsmSp root = asmBeginArgCheck(bco);
262 asmEndArgCheck(bco,root);
264 /* ppStgExpr(rhs); */
265 cgExpr(bco,root,rhs);
272 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
274 //printf("cgExpr:");ppStgExpr(e);printf("\n");
278 List binds = stgLetBinds(e);
279 map1Proc(alloc,bco,binds);
280 map1Proc(build,bco,binds);
281 cgExpr(bco,root,stgLetBody(e));
286 AsmSp begin = asmBeginEnter(bco);
287 asmClosure(bco,cgLambda(e));
288 asmEndEnter(bco,begin,root);
293 List alts = stgCaseAlts(e);
294 AsmSp sp = asmBeginCase(bco);
295 AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
296 cgExpr(bco,caseroot,stgCaseScrut(e));
302 StgExpr scrut = stgPrimCaseScrut(e);
303 List alts = stgPrimCaseAlts(e);
304 if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
306 /* No need to use return address or to Slide */
307 AsmSp beginPrim = asmBeginPrim(bco);
308 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
309 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
311 for(; nonNull(alts); alts=tl(alts)) {
312 StgPrimAlt alt = hd(alts);
313 List pats = stgPrimAltPats(alt);
314 StgExpr body = stgPrimAltBody(alt);
315 AsmSp altBegin = asmBeginAlt(bco);
316 map1Proc(cgBind,bco,reverse(pats));
317 testPrimPats(bco,root,pats,body);
318 asmEndAlt(bco,altBegin);
320 /* if we got this far and didn't match, panic! */
323 } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
325 /* No need to use return address or to Slide */
327 /* only part different from primop code... todo */
328 AsmSp beginCase = asmBeginCase(bco);
330 asmEndAlt(bco,beginCase); /* hack, hack - */
332 for(; nonNull(alts); alts=tl(alts)) {
333 StgPrimAlt alt = hd(alts);
334 List pats = stgPrimAltPats(alt);
335 StgExpr body = stgPrimAltBody(alt);
336 AsmSp altBegin = asmBeginAlt(bco);
337 map1Proc(cgBind,bco,pats);
338 testPrimPats(bco,root,pats,body);
339 asmEndAlt(bco,altBegin);
341 /* if we got this far and didn't match, panic! */
345 /* ToDo: implement this code... */
347 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
348 /* cgExpr( bco,root,scrut ); */
352 case STGAPP: /* Tail call */
354 AsmSp env = asmBeginEnter(bco);
355 map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
356 pushAtom(bco,stgAppFun(e));
357 asmEndEnter(bco,env,root);
360 case NAME: /* Tail call (with no args) */
362 AsmSp env = asmBeginEnter(bco);
363 pushVar(bco,name(e).stgVar);
364 asmEndEnter(bco,env,root);
367 case STGVAR: /* Tail call (with no args), plus unboxed return */
373 AsmSp env = asmBeginEnter(bco);
375 asmEndEnter(bco,env,root);
380 /* cgTailCall(bco,singleton(e)); */
381 /* asmReturnInt(bco); */
384 internal("cgExpr StgVar");
387 case STGPRIM: /* Tail call again */
389 AsmSp beginPrim = asmBeginPrim(bco);
390 map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
391 asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
392 /* map1Proc(cgBind,bco,rs_vars); */
393 assert(0); /* asmReturn_retty(); */
397 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
402 void* itblNames[1000];
405 /* allocate space for top level variable
406 * any change requires a corresponding change in 'build'.
408 static Void alloc( AsmBCO bco, StgVar v )
410 StgRhs rhs = stgVarBody(v);
412 switch (whatIs(rhs)) {
415 StgDiscr con = stgConCon(rhs);
416 List args = stgConArgs(rhs);
417 if (isBoxingCon(con)) {
418 pushAtom(bco,hd(args));
419 setPos(v,asmBox(bco,boxingConRep(con)));
422 void* vv = stgConInfo(con);
423 assert (nItblNames < (1000-2));
425 itblNames[nItblNames++] = vv;
426 itblNames[nItblNames++] = textToStr(name(con).text);
429 char* cc = malloc(10);
431 sprintf(cc, "Tuple%d", tupleOf(con) );
432 itblNames[nItblNames++] = vv;
433 itblNames[nItblNames++] = cc;
435 assert ( /* cant identify constructor name */ 0 );
437 setPos(v,asmAllocCONSTR(bco, vv));
442 setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
444 case LAMBDA: /* optimisation */
445 setObj(v,cgLambda(rhs));
448 setPos(v,asmAllocAP(bco,0));
453 static Void build( AsmBCO bco, StgVar v )
455 StgRhs rhs = stgVarBody(v);
458 switch (whatIs(rhs)) {
461 StgDiscr con = stgConCon(rhs);
462 List args = stgConArgs(rhs);
463 if (isBoxingCon(con)) {
464 doNothing(); /* already done in alloc */
466 AsmSp start = asmBeginPack(bco);
467 map1Proc(pushAtom,bco,reverse(args));
468 asmEndPack(bco,getPos(v),start,stgConInfo(con));
474 StgVar fun = stgAppFun(rhs);
475 List args = stgAppArgs(rhs);
477 fun = name(fun).stgVar;
479 if (nonNull(stgVarBody(fun))
480 && whatIs(stgVarBody(fun)) == LAMBDA
481 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
482 AsmSp start = asmBeginMkPAP(bco);
483 map1Proc(pushAtom,bco,reverse(args));
485 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
487 AsmSp start = asmBeginMkAP(bco);
488 map1Proc(pushAtom,bco,reverse(args));
490 asmEndMkAP(bco,getPos(v),start);
494 case LAMBDA: /* optimisation */
495 doNothing(); /* already pushed in alloc */
498 /* These two cases look almost identical to the default but they're really
499 * special cases of STGAPP. The essential thing here is that we can't call
500 * cgRhs(rhs) because that expects the rhs to have no free variables when,
501 * in fact, the rhs is _always_ a free variable.
503 * ToDo: a simple optimiser would eliminate all examples
504 * of this except "let x = x in ..."
507 rhs = name(rhs).stgVar;
510 AsmSp start = asmBeginMkAP(bco);
512 asmEndMkAP(bco,getPos(v),start);
517 AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
518 asmClosure(bco,cgRhs(rhs));
519 asmEndMkAP(bco,getPos(v),start);
525 /* --------------------------------------------------------------------------
526 * Top level variables
528 * ToDo: these should be handled by allocating a dynamic unentered CAF
529 * for each top level variable - this should be simpler!
530 * ------------------------------------------------------------------------*/
532 #if 0 /* appears to be unused */
533 static void cgAddVar( AsmObject obj, StgAtom v )
539 asmAddPtr(obj,getObj(v));
544 /* allocate AsmObject for top level variables
545 * any change requires a corresponding change in endTop
547 static void beginTop( StgVar v )
552 switch (whatIs(rhs)) {
555 //List as = stgConArgs(rhs);
556 setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
560 setObj(v,asmBeginBCO(rhs));
563 setObj(v,asmBeginCAF());
568 static void endTop( StgVar v )
570 StgRhs rhs = stgVarBody(v);
572 switch (whatIs(rhs)) {
575 List as = stgConArgs(rhs);
576 AsmCon con = (AsmCon)getObj(v);
577 for( ; nonNull(as); as=tl(as)) {
581 /* should be a delayed combinator! */
582 asmAddPtr(con,(AsmObject)getObj(a));
586 StgVar var = name(a).stgVar;
588 asmAddPtr(con,(AsmObject)getObj(a));
591 #if !USE_ADDR_FOR_STRINGS
593 asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
597 /* asmAddPtr(con,??); */
605 case LAMBDA: /* optimisation */
607 /* ToDo: merge this code with cgLambda */
608 AsmBCO bco = (AsmBCO)getObj(v);
609 AsmSp root = asmBeginArgCheck(bco);
610 map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
611 asmEndArgCheck(bco,root);
613 cgExpr(bco,root,stgLambdaBody(rhs));
618 default: /* updateable caf */
620 AsmCAF caf = (AsmCAF)getObj(v);
621 asmEndCAF(caf,cgRhs(rhs));
627 static void zap( StgVar v )
630 // stgVarBody(v) = NIL;
633 /* external entry point */
634 Void cgBinds( List binds )
639 //if (lastModule() != modulePrelude) {
640 // printf("\n\ncgBinds: before ll\n\n" );
641 // for (b=binds; nonNull(b); b=tl(b)) {
642 // printStg ( stdout, hd(b) ); printf("\n\n");
646 binds = liftBinds(binds);
648 //if (lastModule() != modulePrelude) {
649 // printf("\n\ncgBinds: after ll\n\n" );
650 // for (b=binds; nonNull(b); b=tl(b)) {
651 // printStg ( stdout, hd(b) ); printf("\n\n");
656 //mapProc(beginTop,binds);
657 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
658 //printf("beginTop %d\n", i);
662 //mapProc(endTop,binds);
663 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
665 //if (lastModule() != modulePrelude) {
666 // printStg ( stdout, hd(b) ); printf("\n\n");
670 //mapProc(zap,binds);
673 /* --------------------------------------------------------------------------
674 * Code Generator control:
675 * ------------------------------------------------------------------------*/
681 /* deliberate fall though */
690 /*-------------------------------------------------------------------------*/