1 /* -*- mode: hugs-c; -*- */
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: 1998/12/02 13:21:59 $
12 * ------------------------------------------------------------------------*/
19 #include "Assembler.h"
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);
110 asmClosure(bco,ptrOf(info));
111 } else if (isInt(info)) {
112 asmVar(bco,intOf(info),repOf(v));
118 static Void pushAtom( AsmBCO bco, StgAtom e )
125 pushVar(bco,name(e).stgVar);
128 asmConstChar(bco,charOf(e));
131 asmConstInt(bco,intOf(e));
133 #if BIGNUM_IS_INTEGER
135 asmConstInteger(bco,bignumToString(e));
137 #elif BIGNUM_IS_INT64
139 asmConstInt64(bco,bignumOf(e));
142 #warning What is BIGNUM?
146 asmConstFloat(bco,e); /* ToDo: support both float and double! */
148 asmConstDouble(bco,floatOf(e));
153 asmConstDouble(bco,doubleOf(e));
157 #if USE_ADDR_FOR_STRINGS
158 asmConstAddr(bco,textToStr(textOf(e)));
160 asmClosure(bco,asmStringObj(textToStr(textOf(e))));
164 asmConstAddr(bco,ptrOf(e));
167 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
168 internal("pushAtom");
172 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
174 AsmBCO bco = asmBeginContinuation(sp);
175 /* ppStgAlts(alts); */
176 for(; nonNull(alts); alts=tl(alts)) {
177 StgCaseAlt alt = hd(alts);
178 StgPat pat = stgCaseAltPat(alt);
179 StgExpr body = stgCaseAltBody(alt);
180 if (isDefaultPat(pat)) {
181 AsmSp begin = asmBeginAlt(bco);
183 cgExpr(bco,root,body);
184 asmEndContinuation(bco);
185 return bco; /* ignore any further alternatives */
187 StgDiscr con = stgPatDiscr(pat);
188 List vs = stgPatVars(pat);
189 AsmSp begin = asmBeginAlt(bco);
190 AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
192 if (isBoxingCon(con)) {
193 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
196 map1Proc(cgBind,bco,reverse(vs));
199 cgExpr(bco,root,body);
200 asmEndAlt(bco,begin);
201 asmFixBranch(bco,fix);
204 /* if we got this far and didn't match, panic! */
206 asmEndContinuation(bco);
210 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
215 StgPrimPat pat = hd(pats);
216 if (isInt(stgVarBody(pat))) {
217 /* asmTestInt leaves stack unchanged - so no need to adjust it */
218 AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
219 assert(repOf(pat) == INT_REP);
220 testPrimPats(bco,root,tl(pats),e);
221 asmFixBranch(bco,tst);
223 testPrimPats(bco,root,tl(pats),e);
228 static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
230 assert(0); /* ToDo: test for patterns */
231 map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
235 static AsmBCO cgLambda( StgExpr e )
237 AsmBCO bco = asmBeginBCO();
239 AsmSp root = asmBeginArgCheck(bco);
240 map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
241 asmEndArgCheck(bco,root);
244 cgExpr(bco,root,stgLambdaBody(e));
250 static AsmBCO cgRhs( StgRhs rhs )
252 AsmBCO bco = asmBeginBCO( );
254 AsmSp root = asmBeginArgCheck(bco);
255 asmEndArgCheck(bco,root);
257 /* ppStgExpr(rhs); */
258 cgExpr(bco,root,rhs);
264 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
269 List binds = stgLetBinds(e);
270 map1Proc(alloc,bco,binds);
271 map1Proc(build,bco,binds);
272 cgExpr(bco,root,stgLetBody(e));
277 AsmSp begin = asmBeginEnter(bco);
278 asmClosure(bco,cgLambda(e));
279 asmEndEnter(bco,begin,root);
284 List alts = stgCaseAlts(e);
285 AsmSp sp = asmBeginCase(bco);
286 AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
287 cgExpr(bco,caseroot,stgCaseScrut(e));
293 StgExpr scrut = stgPrimCaseScrut(e);
294 List alts = stgPrimCaseAlts(e);
295 if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
297 /* No need to use return address or to Slide */
298 AsmSp beginPrim = asmBeginPrim(bco);
299 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
300 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
302 for(; nonNull(alts); alts=tl(alts)) {
303 StgPrimAlt alt = hd(alts);
304 List pats = stgPrimAltPats(alt);
305 StgExpr body = stgPrimAltBody(alt);
306 AsmSp altBegin = asmBeginAlt(bco);
307 map1Proc(cgBind,bco,reverse(pats));
308 testPrimPats(bco,root,pats,body);
309 asmEndAlt(bco,altBegin);
311 /* if we got this far and didn't match, panic! */
314 } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
316 /* No need to use return address or to Slide */
318 /* only part different from primop code... todo */
319 AsmSp beginCase = asmBeginCase(bco);
321 asmEndAlt(bco,beginCase); /* hack, hack - */
323 for(; nonNull(alts); alts=tl(alts)) {
324 StgPrimAlt alt = hd(alts);
325 List pats = stgPrimAltPats(alt);
326 StgExpr body = stgPrimAltBody(alt);
327 AsmSp altBegin = asmBeginAlt(bco);
328 map1Proc(cgBind,bco,pats);
329 testPrimPats(bco,root,pats,body);
330 asmEndAlt(bco,altBegin);
332 /* if we got this far and didn't match, panic! */
336 /* ToDo: implement this code... */
338 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
339 /* cgExpr( bco,root,scrut ); */
343 case STGAPP: /* Tail call */
345 AsmSp env = asmBeginEnter(bco);
346 map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
347 pushAtom(bco,stgAppFun(e));
348 asmEndEnter(bco,env,root);
351 case NAME: /* Tail call (with no args) */
353 AsmSp env = asmBeginEnter(bco);
354 pushVar(bco,name(e).stgVar);
355 asmEndEnter(bco,env,root);
358 case STGVAR: /* Tail call (with no args), plus unboxed return */
364 AsmSp env = asmBeginEnter(bco);
366 asmEndEnter(bco,env,root);
371 /* cgTailCall(bco,singleton(e)); */
372 /* asmReturnInt(bco); */
375 internal("cgExpr StgVar");
378 case STGPRIM: /* Tail call again */
380 AsmSp beginPrim = asmBeginPrim(bco);
381 map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
382 asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
383 /* map1Proc(cgBind,bco,rs_vars); */
384 assert(0); /* asmReturn_retty(); */
388 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
393 /* allocate space for top level variable
394 * any change requires a corresponding change in 'build'.
396 static Void alloc( AsmBCO bco, StgVar v )
398 StgRhs rhs = stgVarBody(v);
400 switch (whatIs(rhs)) {
403 StgDiscr con = stgConCon(rhs);
404 List args = stgConArgs(rhs);
405 if (isBoxingCon(con)) {
406 pushAtom(bco,hd(args));
407 setPos(v,asmBox(bco,boxingConRep(con)));
409 setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
414 setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
416 case LAMBDA: /* optimisation */
417 setObj(v,cgLambda(rhs));
420 setPos(v,asmAllocAP(bco,0));
425 static Void build( AsmBCO bco, StgVar v )
427 StgRhs rhs = stgVarBody(v);
429 switch (whatIs(rhs)) {
432 StgDiscr con = stgConCon(rhs);
433 List args = stgConArgs(rhs);
434 if (isBoxingCon(con)) {
435 doNothing(); /* already done in alloc */
437 AsmSp start = asmBeginPack(bco);
438 map1Proc(pushAtom,bco,reverse(args));
439 asmEndPack(bco,getPos(v),start,stgConInfo(con));
445 StgVar fun = stgAppFun(rhs);
446 List args = stgAppArgs(rhs);
448 fun = name(fun).stgVar;
450 if (nonNull(stgVarBody(fun))
451 && whatIs(stgVarBody(fun)) == LAMBDA
452 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
453 AsmSp start = asmBeginMkPAP(bco);
454 map1Proc(pushAtom,bco,reverse(args));
456 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
458 AsmSp start = asmBeginMkAP(bco);
459 map1Proc(pushAtom,bco,reverse(args));
461 asmEndMkAP(bco,getPos(v),start);
465 case LAMBDA: /* optimisation */
466 doNothing(); /* already pushed in alloc */
469 /* These two cases look almost identical to the default but they're really
470 * special cases of STGAPP. The essential thing here is that we can't call
471 * cgRhs(rhs) because that expects the rhs to have no free variables when,
472 * in fact, the rhs is _always_ a free variable.
474 * ToDo: a simple optimiser would eliminate all examples
475 * of this except "let x = x in ..."
478 rhs = name(rhs).stgVar;
481 AsmSp start = asmBeginMkAP(bco);
483 asmEndMkAP(bco,getPos(v),start);
488 AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
489 asmClosure(bco,cgRhs(rhs));
490 asmEndMkAP(bco,getPos(v),start);
496 /* --------------------------------------------------------------------------
497 * Top level variables
499 * ToDo: these should be handled by allocating a dynamic unentered CAF
500 * for each top level variable - this should be simpler!
501 * ------------------------------------------------------------------------*/
503 static void cgAddVar( AsmObject obj, StgAtom v )
509 asmAddPtr(obj,getObj(v));
512 /* allocate AsmObject for top level variables
513 * any change requires a corresponding change in endTop
515 static void beginTop( StgVar v )
520 switch (whatIs(rhs)) {
523 List as = stgConArgs(rhs);
524 setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
528 setObj(v,asmBeginBCO());
531 setObj(v,asmBeginCAF());
536 static void endTop( StgVar v )
538 StgRhs rhs = stgVarBody(v);
540 switch (whatIs(rhs)) {
543 List as = stgConArgs(rhs);
544 AsmCon con = (AsmCon)getObj(v);
545 for( ; nonNull(as); as=tl(as)) {
549 /* should be a delayed combinator! */
550 asmAddPtr(con,(AsmObject)getObj(a));
554 StgVar var = name(a).stgVar;
556 asmAddPtr(con,(AsmObject)getObj(a));
559 #if !USE_ADDR_FOR_STRINGS
561 asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
565 /* asmAddPtr(con,??); */
573 case LAMBDA: /* optimisation */
575 /* ToDo: merge this code with cgLambda */
576 AsmBCO bco = (AsmBCO)getObj(v);
577 AsmSp root = asmBeginArgCheck(bco);
578 map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
579 asmEndArgCheck(bco,root);
581 cgExpr(bco,root,stgLambdaBody(rhs));
586 default: /* updateable caf */
588 AsmCAF caf = (AsmCAF)getObj(v);
589 asmEndCAF(caf,cgRhs(rhs));
595 static void zap( StgVar v )
600 /* external entry point */
601 Void cgBinds( List binds )
603 binds = liftBinds(binds);
604 mapProc(beginTop,binds);
605 mapProc(endTop,binds);
609 /* --------------------------------------------------------------------------
610 * Code Generator control:
611 * ------------------------------------------------------------------------*/
617 /* deliberate fall though */
626 /*-------------------------------------------------------------------------*/