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/07/06 15:24:36 $
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 static StgVar currentTop;
53 /* --------------------------------------------------------------------------
55 * ------------------------------------------------------------------------*/
57 static Cell cptrFromName ( Name n )
61 Module m = name(n).mod;
62 Text mt = module(m).text;
63 sprintf(buf,"%s_%s_closure",
64 textToStr(mt), textToStr(name(n).text) );
65 p = lookupOTabName ( m, buf );
67 ERRMSG(0) "Can't find object symbol %s", buf
73 static Bool varHasClosure( StgVar v )
75 return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
78 /* should be AsmClosure* */
79 void* closureOfVar( StgVar v )
81 return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
84 char* lookupHugsName( void* closure )
88 for( nm=NAMEMIN; nm<nameHw; ++nm ) {
89 StgVar v = name(nm).stgVar;
91 && isPtr(stgVarInfo(v))
93 && closureOfVar(v) == closure) {
94 return textToStr(name(nm).text);
100 /* called at the start of GC */
101 void markHugsObjects( void )
105 for( nm=NAMEMIN; nm<nameHw; ++nm ) {
106 StgVar v = name(nm).stgVar;
107 if (isStgVar(v) && isPtr(stgVarInfo(v))) {
108 asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
113 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
115 setPos(v,asmBind(bco,rep));
118 static void cgBind( AsmBCO bco, StgVar v )
120 cgBindRep(bco,v,repOf(v));
123 static Void pushVar( AsmBCO bco, StgVar v )
127 if (!(isStgVar(v) || isCPtr(v))) {
128 assert(isStgVar(v) || isCPtr(v));
132 asmGHCClosure(bco, cptrOf(v));
134 info = stgVarInfo(v);
136 asmClosure(bco,ptrOf(info));
137 } else if (isInt(info)) {
138 asmVar(bco,intOf(info),repOf(v));
145 static Void pushAtom( AsmBCO bco, StgAtom e )
152 if (nonNull(name(e).stgVar))
153 pushVar(bco,name(e).stgVar); else
154 pushVar(bco,cptrFromName(e));
157 asmConstChar(bco,charOf(e));
160 asmConstInt(bco,intOf(e));
163 asmConstInteger(bco,bignumToString(e));
167 asmConstFloat(bco,e); /* ToDo: support both float and double! */
169 asmConstDouble(bco,floatOf(e));
174 asmConstDouble(bco,doubleOf(e));
178 #if USE_ADDR_FOR_STRINGS
179 asmConstAddr(bco,textToStr(textOf(e)));
181 asmClosure(bco,asmStringObj(textToStr(textOf(e))));
185 asmGHCClosure(bco,cptrOf(e));
188 asmConstAddr(bco,ptrOf(e));
191 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
192 internal("pushAtom");
196 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
198 #ifdef CRUDE_PROFILING
199 AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
201 AsmBCO bco = asmBeginContinuation(sp, alts);
203 /* ppStgAlts(alts); */
204 for(; nonNull(alts); alts=tl(alts)) {
205 StgCaseAlt alt = hd(alts);
206 if (isDefaultAlt(alt)) {
207 cgBind(bco,stgDefaultVar(alt));
208 cgExpr(bco,root,stgDefaultBody(alt));
209 asmEndContinuation(bco);
210 return bco; /* ignore any further alternatives */
212 StgDiscr con = stgCaseAltCon(alt);
213 List vs = stgCaseAltVars(alt);
214 AsmSp begin = asmBeginAlt(bco);
215 AsmPc fix = asmTest(bco,stgDiscrTag(con));
216 /* ToDo: omit in single constructor types! */
217 asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
218 if (isBoxingCon(con)) {
219 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
222 map1Proc(cgBind,bco,reverse(vs));
225 cgExpr(bco,root,stgCaseAltBody(alt));
226 asmEndAlt(bco,begin);
227 asmFixBranch(bco,fix);
230 /* if we got this far and didn't match, panic! */
232 asmEndContinuation(bco);
236 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
241 StgVar pat = hd(pats);
242 if (isInt(stgVarBody(pat))) {
243 /* asmTestInt leaves stack unchanged - so no need to adjust it */
244 AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
245 assert(repOf(pat) == INT_REP);
246 testPrimPats(bco,root,tl(pats),e);
247 asmFixBranch(bco,tst);
249 testPrimPats(bco,root,tl(pats),e);
254 #if 0 /* appears to be unused */
255 static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
257 assert(0); /* ToDo: test for patterns */
258 map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
264 static AsmBCO cgLambda( StgExpr e )
266 AsmBCO bco = asmBeginBCO(e);
268 AsmSp root = asmBeginArgCheck(bco);
269 map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
270 asmEndArgCheck(bco,root);
273 cgExpr(bco,root,stgLambdaBody(e));
279 static AsmBCO cgRhs( StgRhs rhs )
281 AsmBCO bco = asmBeginBCO(rhs );
283 AsmSp root = asmBeginArgCheck(bco);
284 asmEndArgCheck(bco,root);
286 /* ppStgExpr(rhs); */
287 cgExpr(bco,root,rhs);
294 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
296 //printf("cgExpr:");ppStgExpr(e);printf("\n");
300 List binds = stgLetBinds(e);
301 map1Proc(alloc,bco,binds);
302 map1Proc(build,bco,binds);
303 cgExpr(bco,root,stgLetBody(e));
308 AsmSp begin = asmBeginEnter(bco);
309 asmClosure(bco,cgLambda(e));
310 asmEndEnter(bco,begin,root);
315 List alts = stgCaseAlts(e);
316 AsmSp sp = asmBeginCase(bco);
317 AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
318 cgExpr(bco,caseroot,stgCaseScrut(e));
324 StgExpr scrut = stgPrimCaseScrut(e);
325 List alts = stgPrimCaseAlts(e);
326 if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
328 /* No need to use return address or to Slide */
329 AsmSp beginPrim = asmBeginPrim(bco);
330 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
331 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
333 for(; nonNull(alts); alts=tl(alts)) {
334 StgPrimAlt alt = hd(alts);
335 List pats = stgPrimAltVars(alt);
336 StgExpr body = stgPrimAltBody(alt);
337 AsmSp altBegin = asmBeginAlt(bco);
338 map1Proc(cgBind,bco,reverse(pats));
339 testPrimPats(bco,root,pats,body);
340 asmEndAlt(bco,altBegin);
342 /* if we got this far and didn't match, panic! */
345 } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
347 /* No need to use return address or to Slide */
349 /* only part different from primop code... todo */
350 AsmSp beginCase = asmBeginCase(bco);
352 asmEndAlt(bco,beginCase); /* hack, hack - */
354 for(; nonNull(alts); alts=tl(alts)) {
355 StgPrimAlt alt = hd(alts);
356 List pats = stgPrimAltVars(alt);
357 StgExpr body = stgPrimAltBody(alt);
358 AsmSp altBegin = asmBeginAlt(bco);
359 map1Proc(cgBind,bco,pats);
360 testPrimPats(bco,root,pats,body);
361 asmEndAlt(bco,altBegin);
363 /* if we got this far and didn't match, panic! */
367 /* ToDo: implement this code... */
369 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
370 /* cgExpr( bco,root,scrut ); */
374 case STGAPP: /* Tail call */
376 AsmSp env = asmBeginEnter(bco);
377 map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
378 pushAtom(bco,stgAppFun(e));
379 asmEndEnter(bco,env,root);
382 case NAME: /* Tail call (with no args) */
384 AsmSp env = asmBeginEnter(bco);
385 pushVar(bco,name(e).stgVar);
386 asmEndEnter(bco,env,root);
389 case STGVAR: /* Tail call (with no args), plus unboxed return */
395 AsmSp env = asmBeginEnter(bco);
397 asmEndEnter(bco,env,root);
402 /* cgTailCall(bco,singleton(e)); */
403 /* asmReturnInt(bco); */
406 internal("cgExpr StgVar");
409 case STGPRIM: /* Tail call again */
411 AsmSp beginPrim = asmBeginPrim(bco);
412 map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
413 asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
414 /* map1Proc(cgBind,bco,rs_vars); */
415 assert(0); /* asmReturn_retty(); */
419 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
424 #define M_ITBLNAMES 35000
426 void* itblNames[M_ITBLNAMES];
429 /* allocate space for top level variable
430 * any change requires a corresponding change in 'build'.
432 static Void alloc( AsmBCO bco, StgVar v )
434 StgRhs rhs = stgVarBody(v);
436 switch (whatIs(rhs)) {
439 StgDiscr con = stgConCon(rhs);
440 List args = stgConArgs(rhs);
441 if (isBoxingCon(con)) {
442 pushAtom(bco,hd(args));
443 setPos(v,asmBox(bco,boxingConRep(con)));
446 void* vv = stgConInfo(con);
447 if (!(nItblNames < (M_ITBLNAMES-2)))
448 internal("alloc -- M_ITBLNAMES too small");
450 itblNames[nItblNames++] = vv;
451 itblNames[nItblNames++] = textToStr(name(con).text);
454 char* cc = malloc(10);
456 sprintf(cc, "Tuple%d", tupleOf(con) );
457 itblNames[nItblNames++] = vv;
458 itblNames[nItblNames++] = cc;
460 assert ( /* cant identify constructor name */ 0 );
462 setPos(v,asmAllocCONSTR(bco, vv));
468 List bs = stgAppArgs(rhs);
469 for (; nonNull(bs); bs=tl(bs)) {
470 if (isName(hd(bs))) {
473 ASSERT(whatIs(hd(bs))==STGVAR);
474 totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
477 setPos(v,asmAllocAP(bco,totSizeW));
478 //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
481 case LAMBDA: /* optimisation */
482 setObj(v,cgLambda(rhs));
485 setPos(v,asmAllocAP(bco,0));
490 static Void build( AsmBCO bco, StgVar v )
492 StgRhs rhs = stgVarBody(v);
495 switch (whatIs(rhs)) {
498 StgDiscr con = stgConCon(rhs);
499 List args = stgConArgs(rhs);
500 if (isBoxingCon(con)) {
501 doNothing(); /* already done in alloc */
503 AsmSp start = asmBeginPack(bco);
504 map1Proc(pushAtom,bco,reverse(args));
505 asmEndPack(bco,getPos(v),start,stgConInfo(con));
512 StgVar fun = stgAppFun(rhs);
514 List args = stgAppArgs(rhs);
516 if (nonNull(name(fun).stgVar))
517 fun = name(fun).stgVar; else
518 fun = cptrFromName(fun);
522 assert(isName(fun0));
523 itsaPAP = name(fun0).arity > length(args);
524 fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
525 nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) );
528 if (nonNull(stgVarBody(fun))
529 && whatIs(stgVarBody(fun)) == LAMBDA
530 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
536 AsmSp start = asmBeginMkPAP(bco);
537 map1Proc(pushAtom,bco,reverse(args));
539 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
541 AsmSp start = asmBeginMkAP(bco);
542 map1Proc(pushAtom,bco,reverse(args));
544 asmEndMkAP(bco,getPos(v),start);
548 case LAMBDA: /* optimisation */
549 doNothing(); /* already pushed in alloc */
552 /* These two cases look almost identical to the default but they're really
553 * special cases of STGAPP. The essential thing here is that we can't call
554 * cgRhs(rhs) because that expects the rhs to have no free variables when,
555 * in fact, the rhs is _always_ a free variable.
557 * ToDo: a simple optimiser would eliminate all examples
558 * of this except "let x = x in ..."
561 rhs = name(rhs).stgVar;
564 AsmSp start = asmBeginMkAP(bco);
566 asmEndMkAP(bco,getPos(v),start);
571 AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
572 asmClosure(bco,cgRhs(rhs));
573 asmEndMkAP(bco,getPos(v),start);
579 /* --------------------------------------------------------------------------
580 * Top level variables
582 * ToDo: these should be handled by allocating a dynamic unentered CAF
583 * for each top level variable - this should be simpler!
584 * ------------------------------------------------------------------------*/
586 #if 0 /* appears to be unused */
587 static void cgAddVar( AsmObject obj, StgAtom v )
593 asmAddPtr(obj,getObj(v));
598 /* allocate AsmObject for top level variables
599 * any change requires a corresponding change in endTop
601 static void beginTop( StgVar v )
607 switch (whatIs(rhs)) {
610 //List as = stgConArgs(rhs);
611 setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
615 #ifdef CRUDE_PROFILING
616 setObj(v,asmBeginBCO(currentTop));
618 setObj(v,asmBeginBCO(rhs));
622 setObj(v,asmBeginCAF());
627 static void endTop( StgVar v )
629 StgRhs rhs = stgVarBody(v);
631 switch (whatIs(rhs)) {
634 List as = stgConArgs(rhs);
635 AsmCon con = (AsmCon)getObj(v);
636 for( ; nonNull(as); as=tl(as)) {
640 /* should be a delayed combinator! */
641 asmAddPtr(con,(AsmObject)getObj(a));
645 StgVar var = name(a).stgVar;
647 asmAddPtr(con,(AsmObject)getObj(a));
650 #if !USE_ADDR_FOR_STRINGS
652 asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
656 /* asmAddPtr(con,??); */
664 case LAMBDA: /* optimisation */
666 /* ToDo: merge this code with cgLambda */
667 AsmBCO bco = (AsmBCO)getObj(v);
668 AsmSp root = asmBeginArgCheck(bco);
669 map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
670 asmEndArgCheck(bco,root);
672 cgExpr(bco,root,stgLambdaBody(rhs));
677 default: /* updateable caf */
679 AsmCAF caf = (AsmCAF)getObj(v);
680 asmEndCAF(caf,cgRhs(rhs));
686 static void zap( StgVar v )
689 // stgVarBody(v) = NIL;
692 /* external entry point */
693 Void cgBinds( List binds )
699 if (lastModule() != modulePrelude) {
700 printf("\n\ncgBinds: before ll\n\n" );
701 for (b=binds; nonNull(b); b=tl(b)) {
702 printStg ( stdout, hd(b) ); printf("\n\n");
707 binds = liftBinds(binds);
710 if (lastModule() != modulePrelude) {
711 printf("\n\ncgBinds: after ll\n\n" );
712 for (b=binds; nonNull(b); b=tl(b)) {
713 printStg ( stdout, hd(b) ); printf("\n\n");
718 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
722 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
723 //printf("endTop %s\n", maybeName(hd(b)));
727 //mapProc(zap,binds);
730 /* --------------------------------------------------------------------------
731 * Code Generator control:
732 * ------------------------------------------------------------------------*/
738 /* deliberate fall though */
747 /*-------------------------------------------------------------------------*/