ghc/interpreter/translate.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Translator: generates stg code from output of pattern matching
   4  * compiler.
   5  *
   6  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   7  * All rights reserved. See NOTICE for details and conditions of use etc...
   8  * Hugs version 1.4, December 1997
   9  *
  10  * $RCSfile: translate.c,v $
  11  * $Revision: 1.7 $
  12  * $Date: 1999/04/27 10:07:08 $
  13  * ------------------------------------------------------------------------*/
  14
  15 #include "prelude.h"
  16 #include "storage.h"
  17 #include "backend.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20 #include "link.h"
  21 #include "dynamic.h"
  22 #include "Assembler.h"
  23
  24
  25 /* ---------------------------------------------------------------- */
  26
  27 static StgVar  local stgOffset       Args((Offset,List));
  28 static StgVar  local stgText         Args((Text,List));
  29 static StgRhs  local stgRhs          Args((Cell,Int,List,StgExpr));
  30 static StgCaseAlt local stgCaseAlt   Args((Cell,Int,List,StgExpr));
  31 static StgExpr local stgExpr         Args((Cell,Int,List,StgExpr));
  32
  33 /* ---------------------------------------------------------------- */
  34
  35 /* Association list storing globals assigned to                     */
  36 /* dictionaries, tuples, etc                                        */
  37 List stgGlobals = NIL;
  38
  39 static StgVar local getSTGTupleVar  Args((Cell));
  40
  41 static StgVar local getSTGTupleVar( Cell d )
  42 {
  43     Pair p = cellAssoc(d,stgGlobals);
  44     /* Yoiks - only the Prelude sees Tuple decls! */
  45     if (isNull(p)) {
  46         implementTuple(tupleOf(d));
  47         p = cellAssoc(d,stgGlobals);
  48     }
  49     assert(nonNull(p));
  50     return snd(p);
  51 }
  52
  53 /* ---------------------------------------------------------------- */
  54
  55 static Cell local stgOffset(Offset o, List sc)
  56 {
  57     Cell r = cellAssoc(o,sc);
  58     assert(nonNull(r));
  59     return snd(r);
  60 }
  61
  62 static Cell local stgText(Text t,List sc)
  63 {
  64     List xs = sc;
  65     for (; nonNull(xs); xs=tl(xs)) {
  66         Cell x = hd(xs);
  67         Cell v = fst(x);
  68         if (!isOffset(v) && t == textOf(v)) {
  69             return snd(x);
  70         }
  71     }
  72     internal("stgText");
  73 }
  74
  75 /* ---------------------------------------------------------------- */
  76
  77 static StgRhs local stgRhs(e,co,sc,failExpr)
  78 Cell e;
  79 Int  co;
  80 List sc;
  81 StgExpr failExpr; {
  82     switch (whatIs(e)) {
  83
  84     /* Identifiers */
  85     case OFFSET:
  86             return stgOffset(e,sc);
  87     case VARIDCELL:
  88     case VAROPCELL:
  89             return stgText(textOf(e),sc);
  90     case TUPLE:
  91             return getSTGTupleVar(e);
  92     case NAME:
  93             return e;
  94     /* Literals */
  95     case CHARCELL:
  96             return mkStgCon(nameMkC,singleton(e));
  97     case INTCELL:
  98             return mkStgCon(nameMkI,singleton(e));
  99     case BIGCELL:
 100             return mkStgCon(nameMkInteger,singleton(e));
 101     case FLOATCELL:
 102             return mkStgCon(nameMkD,singleton(e));
 103     case STRCELL:
 104 #if USE_ADDR_FOR_STRINGS
 105         {
 106             StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
 107             return mkStgLet(singleton(v),
 108                             makeStgApp(nameUnpackString,singleton(v)));
 109         }
 110 #else
 111             return mkStgApp(nameUnpackString,singleton(e));
 112 #endif
 113     case AP:
 114             return stgExpr(e,co,sc,namePMFail);
 115     case NIL:
 116             internal("stgRhs2");
 117     default:
 118             return stgExpr(e,co,sc,failExpr/*namePMFail*/);
 119     }
 120 }
 121
 122 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
 123 Cell alt;
 124 Int co;
 125 List sc;
 126 StgExpr failExpr;
 127 {
 128     StgDiscr d     = fst(alt);
 129     Int      da    = discrArity(d);
 130     Cell     vs    = NIL;
 131     Int  i;
 132     for(i=1; i<=da; ++i) {
 133         StgVar nv = mkStgVar(NIL,NIL);
 134         vs    = cons(nv,vs);
 135         sc    = cons(pair(mkOffset(co+i),nv),sc);
 136     }
 137     return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
 138 }
 139
 140 static StgExpr local stgExpr(e,co,sc,failExpr)
 141 Cell e;
 142 Int  co;
 143 List sc;
 144 StgExpr failExpr;
 145 {
 146     switch (whatIs(e)) {
 147     case COND:
 148         {
 149             return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
 150                              stgExpr(snd3(snd(e)),co,sc,failExpr),
 151                              stgExpr(thd3(snd(e)),co,sc,failExpr));
 152         }
 153     case GUARDED:
 154         {
 155             List guards = reverse(snd(e));
 156             e = failExpr;
 157             for(; nonNull(guards); guards=tl(guards)) {
 158                 Cell g   = hd(guards);
 159                 Cell c   = stgExpr(fst(g),co,sc,namePMFail);
 160                 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
 161                 e = makeStgIf(c,rhs,e);
 162             }
 163             return e;
 164         }
 165     case FATBAR:
 166         {
 167             StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
 168             StgVar alt = mkStgVar(e2,NIL);
 169             return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
 170         }
 171     case CASE:
 172         {
 173             List alts  = snd(snd(e));
 174             Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
 175             if (isNull(alts)) {
 176                 return failExpr;
 177             } else if (isChar(fst(hd(alts)))) {
 178                 Cell     alt  = hd(alts);
 179                 StgDiscr d    = fst(alt);
 180                 StgVar   c    = mkStgVar(
 181                                    mkStgCon(nameMkC,singleton(d)),NIL);
 182                 StgExpr  test = nameEqChar;
 183                 /* duplicates scrut but it should be atomic */
 184                 return makeStgIf(
 185                           makeStgLet(singleton(c),
 186                              makeStgApp(test,doubleton(scrut,c))),
 187                           stgExpr(snd(alt),co,sc,failExpr),
 188                           stgExpr(ap(CASE,pair(fst(snd(e)),
 189                              tl(alts))),co,sc,failExpr));
 190             } else {
 191                 List as    = NIL;
 192                 for(; nonNull(alts); alts=tl(alts)) {
 193                     as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
 194                 }
 195                 return mkStgCase(
 196                           scrut,
 197                           revOnto(
 198                              as,
 199                              singleton(mkStgDefault(mkStgVar(NIL,NIL),
 200                                        failExpr))));
 201             }
 202         }
 203     case NUMCASE:
 204 #if OVERLOADED_CONSTANTS
 205         {
 206             Triple nc    = snd(e);
 207             Offset o     = fst3(nc);
 208             Cell   discr = snd3(nc);
 209             Cell   r     = thd3(nc);
 210             Cell   scrut = stgOffset(o,sc);
 211             Cell   h     = getHead(discr);
 212             Int    da    = discrArity(discr);
 213
 214 #if NPLUSK
 215             if (whatIs(h) == ADDPAT && argCount == 1) {
 216                 /*   ADDPAT num dictIntegral
 217                  * ==>
 218                  *   let n = fromInteger num in
 219                  *   if pmLe dictIntegral n scrut
 220                  *   then let v = pmSubtract dictIntegral scrut v
 221                  *   else fail
 222                  */
 223                 Cell   n            = snd(h);
 224                 Cell   dictIntegral = arg(discr);  /* Integral dictionary */
 225                 StgVar v            = NIL;
 226                 List   binds        = NIL;
 227                 StgVar dIntegral    = NIL;
 228
 229                 /* bind dictionary */
 230                 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
 231                 if (!isAtomic(dIntegral)) { /* wasn't atomic */
 232                     dIntegral = mkStgVar(dIntegral,NIL);
 233                     binds = cons(dIntegral,binds);
 234                 }
 235                 /* box number */
 236                 n = mkStgVar(mkStgCon(nameMkInteger,singleton(n)),NIL);
 237                 binds = cons(n,binds);
 238
 239                 /* coerce number to right type (using Integral dict) */
 240                 n = mkStgVar(mkStgApp(
 241                        namePmFromInteger,doubleton(dIntegral,n)),NIL);
 242                 binds = cons(n,binds);
 243
 244                 ++co;
 245                 v = mkStgVar(mkStgApp(
 246                        namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
 247                 return
 248                    mkStgLet(
 249                       binds,
 250                       makeStgIf(
 251                          mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
 252                          mkStgLet(singleton(v),
 253                                   stgExpr(r,
 254                                           co,
 255                                           cons(pair(mkOffset(co),v),sc),
 256                                           failExpr)),
 257                          failExpr));
 258             }
 259 #endif /* NPLUSK */
 260
 261             assert(isName(h) && argCount == 2);
 262             {
 263                 /* This code is rather ugly.
 264                  * We ought to desugar it using one of the following:
 265                  *   if (==) dEq (fromInt     dNum        pat) scrut
 266                  *   if (==) dEq (fromInteger dNum        pat) scrut
 267                  *   if (==) dEq (fromFloat   dFractional pat) scrut
 268                  * But it would be very hard to obtain the Eq dictionary
 269                  * from the Num or Fractional dictionary we have.
 270                  * Instead, we rely on the Prelude to supply 3 helper
 271                  * functions which do the test for us.
 272                  *   primPmInt     :: Num a => Int -> a -> Bool
 273                  *   primPmInteger :: Num a => Integer -> a -> Bool
 274                  *   primPmDouble  :: Fractional a => Double -> a -> Bool
 275                  */
 276                 Cell   n      = arg(discr);
 277                 Cell   dict   = arg(fun(discr));
 278                 StgExpr d     = NIL;
 279                 List    binds = NIL;
 280                 //StgExpr m     = NIL;
 281                 Name   box
 282                     = h == nameFromInt     ? nameMkI
 283                     : h == nameFromInteger ? nameMkInteger
 284                     :                        nameMkD;
 285                 Name   testFun
 286                     = h == nameFromInt     ? namePmInt
 287                     : h == nameFromInteger ? namePmInteger
 288                     :                        namePmDouble;
 289                 Cell   altsc  = sc;
 290                 Cell   vs     = NIL;
 291                 Int    i;
 292
 293                 for(i=1; i<=da; ++i) {
 294                     Cell nv = mkStgVar(NIL,NIL);
 295                     vs    = cons(nv,vs);
 296                     altsc = cons(pair(mkOffset(co+i),nv),altsc);
 297                 }
 298                 /* bind dictionary */
 299                 d = stgRhs(dict,co,sc,namePMFail);
 300                 if (!isAtomic(d)) { /* wasn't atomic */
 301                     d = mkStgVar(d,NIL);
 302                     binds = cons(d,binds);
 303                 }
 304                 /* bind number */
 305                 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
 306                 binds = cons(n,binds);
 307
 308                 return
 309                    makeStgIf(
 310                       mkStgLet(binds,
 311                                mkStgApp(testFun,tripleton(d,n,scrut))),
 312                       stgExpr(r,co+da,altsc,failExpr),
 313                       failExpr
 314                    );
 315             }
 316         }
 317 #else /* ! OVERLOADED_CONSTANTS */
 318         {
 319             Triple nc    = snd(e);
 320             Offset o     = fst3(nc);
 321             Cell   discr = snd3(nc);
 322             Cell   r     = thd3(nc);
 323             Cell   scrut = stgOffset(o,sc);
 324             Cell   h     = getHead(discr);
 325             Int    da    = discrArity(discr);
 326             Cell   n     = discr;
 327             List   binds = NIL;
 328             Name   eq
 329                 = isInt(discr)    ? nameEqInt
 330                 : isBignum(discr) ? nameEqInteger
 331                 :                   nameEqDouble;
 332             Name   box
 333                 = isInt(discr)    ? nameMkI
 334                 : isBignum(discr) ? nameMkBignum
 335                 :                   nameMkD;
 336             StgExpr test = NIL;
 337             Cell   altsc = sc;
 338             Cell   vs    = NIL;
 339             Int    i;
 340
 341             for(i=1; i<=da; ++i) {
 342                 Cell nv = mkStgVar(NIL,NIL);
 343                 vs    = cons(nv,vs);
 344                 altsc = cons(pair(mkOffset(co+i),nv),altsc);
 345             }
 346
 347             /* bind number */
 348             n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
 349             binds = cons(n,binds);
 350
 351             test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
 352             return makeStgIf(test,
 353                              stgExpr(r,co+da,altsc,failExpr),
 354                              failExpr);
 355         }
 356 #endif /* ! OVERLOADED_CONSTANTS */
 357     case LETREC:
 358         {
 359             List binds = NIL;
 360             List vs = NIL;
 361             List bs;
 362             /* allocate variables, extend scope */
 363             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 364                 Cell nv  = mkStgVar(NIL,NIL);
 365                 sc = cons(pair(fst3(hd(bs)),nv),sc);
 366                 binds = cons(nv,binds);
 367                 vs = cons(nv,vs);
 368             }
 369             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 370                 Cell nv  = mkStgVar(NIL,NIL);
 371                 sc = cons(pair(mkOffset(++co),nv),sc);
 372                 binds = cons(nv,binds);
 373                 vs = cons(nv,vs);
 374             }
 375             vs = rev(vs);
 376             /* transform functions */
 377             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 378                 Cell fun = hd(bs);
 379                 Cell nv  = hd(vs);
 380                 List as = NIL;
 381                 List funsc = sc;
 382                 Int  arity = intOf(snd3(fun));
 383                 Int  i;
 384                 for(i=1; i<=arity; ++i) {
 385                     Cell v = mkStgVar(NIL,NIL);
 386                     as = cons(v,as);
 387                     funsc = cons(pair(mkOffset(co+i),v),funsc);
 388                 }
 389                 stgVarBody(nv)
 390                    = mkStgLambda(
 391                         as,
 392                         stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
 393             }
 394             /* transform expressions */
 395             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 396                 Cell rhs = hd(bs);
 397                 Cell nv  = hd(vs);
 398                 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
 399             }
 400             return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
 401         }
 402     default: /* convert to an StgApp or StgVar plus some bindings */
 403         {
 404             List args  = NIL;
 405             List binds = NIL;
 406             List as    = NIL;
 407
 408             /* Unwind args */
 409             while (isAp(e)) {
 410                 Cell arg = arg(e);
 411                 e        = fun(e);
 412                 args = cons(arg,args);
 413             }
 414
 415             /* Special cases */
 416             if (e == nameSel && length(args) == 3) {
 417                 Cell   con   = hd(args);
 418 #if 0
 419                 StgVar v     = stgOffset(hd(tl(args)),sc);
 420 #else
 421                 StgExpr v    = stgExpr(hd(tl(args)),co,sc,namePMFail);
 422 #endif
 423                 Int    ix    = intOf(hd(tl(tl(args))));
 424                 Int    da    = discrArity(con);
 425                 List   vs    = NIL;
 426                 Int    i;
 427                 for(i=1; i<=da; ++i) {
 428                     Cell nv = mkStgVar(NIL,NIL);
 429                     vs=cons(nv,vs);
 430                 }
 431                 return
 432                    mkStgCase(v,
 433                              doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
 434                              mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
 435             }
 436
 437             /* Arguments must be StgAtoms */
 438             for(as=args; nonNull(as); as=tl(as)) {
 439                 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
 440 #if 1 /* optional flattening of let bindings */
 441                 if (whatIs(a) == LETREC) {
 442                     binds = appendOnto(stgLetBinds(a),binds);
 443                     a = stgLetBody(a);
 444                 }
 445 #endif
 446
 447                 if (!isAtomic(a)) {
 448                     a     = mkStgVar(a,NIL);
 449                     binds = cons(a,binds);
 450                 }
 451                 hd(as) = a;
 452             }
 453
 454             /* Function must be StgVar or Name */
 455             e = stgRhs(e,co,sc,namePMFail);
 456             if (!isStgVar(e) && !isName(e)) {
 457                 e = mkStgVar(e,NIL);
 458                 binds = cons(e,binds);
 459             }
 460
 461             return makeStgLet(binds,makeStgApp(e,args));
 462         }
 463     }
 464 }
 465
 466 #if 0 /* apparently not used */
 467 static Void ppExp( Name n, Int arity, Cell e )
 468 {
 469     if (1 || debugCode) {
 470         Int i;
 471         printf("%s", textToStr(name(n).text));
 472         for (i = arity; i > 0; i--) {
 473             printf(" o%d", i);
 474         }
 475         printf(" = ");
 476         printExp(stdout,e);
 477         printf("\n");
 478     }
 479 }
 480 #endif
 481
 482
 483 Void stgDefn( Name n, Int arity, Cell e )
 484 {
 485     List vs = NIL;
 486     List sc = NIL;
 487     Int i, s;
 488     for (i = 1; i <= arity; ++i) {
 489         Cell nv = mkStgVar(NIL,NIL);
 490         vs = cons(nv,vs);
 491         sc = cons(pair(mkOffset(i),nv),sc);
 492     }
 493     stgVarBody(name(n).stgVar)
 494        = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
 495     s = stgSize(stgVarBody(name(n).stgVar));
 496     name(n).stgSize = s;
 497     if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) {
 498        name(n).inlineMe = TRUE;
 499     }
 500 }
 501
 502 Void implementCfun(c,scs)               /* Build implementation for constr */
 503 Name c;                                 /* fun c.  scs lists integers (1..)*/
 504 List scs; {                             /* in incr order of strict comps.  */
 505     Int a = name(c).arity;
 506
 507     if (a > 0) {
 508         StgVar  vcurr, e1, v, vsi;
 509         List    args  = makeArgs(a);
 510         StgVar  v0    = mkStgVar(mkStgCon(c,args),NIL);
 511         List    binds = singleton(v0);
 512
 513         vcurr = v0;
 514         for (; nonNull(scs); scs=tl(scs)) {
 515            vsi   = nth(intOf(hd(scs))-1,args);
 516            vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
 517            binds = cons(vcurr,binds);
 518         }
 519         binds = rev(binds);
 520         e1    = mkStgLet(binds,vcurr);
 521         v     = mkStgVar(mkStgLambda(args,e1),NIL);
 522         name(c).stgVar = v;
 523     } else {
 524         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
 525         name(c).stgVar = v;
 526     }
 527     name(c).inlineMe = TRUE;
 528     name(c).stgSize = stgSize(stgVarBody(name(c).stgVar));
 529     stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
 530     //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n");
 531 }
 532
 533 /* --------------------------------------------------------------------------
 534  * Foreign function calls and primops
 535  * ------------------------------------------------------------------------*/
 536
 537 static String  charListToString( List cs );
 538 static Cell    foreignResultTy( Type t );
 539 static Cell    foreignArgTy( Type t );
 540 static Name    repToBox        Args(( char c ));
 541 static StgRhs  makeStgPrim     Args(( Name,Bool,List,String,String ));
 542
 543 static String charListToString( List cs )
 544 {
 545     static char s[100];
 546
 547     Int i = 0;
 548     assert( length(cs) < 100 );
 549     for(; nonNull(cs); ++i, cs=tl(cs)) {
 550         s[i] = charOf(hd(cs));
 551     }
 552     s[i] = '\0';
 553     return textToStr(findText(s));
 554 }
 555
 556 static Cell foreignResultTy( Type t )
 557 {
 558     if      (t == typeChar)   return mkChar(CHAR_REP);
 559     else if (t == typeInt)    return mkChar(INT_REP);
 560     else if (t == typeInteger)return mkChar(INTEGER_REP);
 561     else if (t == typeWord)   return mkChar(WORD_REP);
 562     else if (t == typeAddr)   return mkChar(ADDR_REP);
 563     else if (t == typeFloat)  return mkChar(FLOAT_REP);
 564     else if (t == typeDouble) return mkChar(DOUBLE_REP);
 565 #ifdef PROVIDE_FOREIGN
 566     else if (t == typeForeign)return mkChar(FOREIGN_REP);
 567          /* ToDo: argty only! */
 568 #endif
 569     else if (t == typePrimByteArray) return mkChar(BARR_REP);
 570          /* ToDo: argty only! */
 571     else if (whatIs(t) == AP) {
 572         Type h = getHead(t);
 573         if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
 574          /* ToDo: argty only! */
 575     }
 576    /* ToDo: decent line numbers! */
 577    ERRMSG(0) "Illegal foreign type" ETHEN
 578    ERRTEXT " \"" ETHEN ERRTYPE(t);
 579    ERRTEXT "\""
 580    EEND;
 581 }
 582
 583 static Cell foreignArgTy( Type t )
 584 {
 585     return foreignResultTy( t );
 586 }
 587
 588 static Name repToBox( char c )
 589 {
 590     switch (c) {
 591     case CHAR_REP:    return nameMkC;
 592     case INT_REP:     return nameMkI;
 593     case INTEGER_REP: return nameMkInteger;
 594     case WORD_REP:    return nameMkW;
 595     case ADDR_REP:    return nameMkA;
 596     case FLOAT_REP:   return nameMkF;
 597     case DOUBLE_REP:  return nameMkD;
 598     case ARR_REP:     return nameMkPrimArray;
 599     case BARR_REP:    return nameMkPrimByteArray;
 600     case REF_REP:     return nameMkRef;
 601     case MUTARR_REP:  return nameMkPrimMutableArray;
 602     case MUTBARR_REP: return nameMkPrimMutableByteArray;
 603 #ifdef PROVIDE_STABLE
 604     case STABLE_REP:  return nameMkStable;
 605 #endif
 606 #ifdef PROVIDE_WEAK
 607     case WEAK_REP:  return nameMkWeak;
 608 #endif
 609 #ifdef PROVIDE_FOREIGN
 610     case FOREIGN_REP: return nameMkForeign;
 611 #endif
 612 #ifdef PROVIDE_CONCURRENT
 613     case THREADID_REP: return nameMkThreadId;
 614     case MVAR_REP:     return nameMkMVar;
 615 #endif
 616     default: return NIL;
 617     }
 618 }
 619
 620 static StgPrimAlt boxResults( String reps, StgVar state )
 621 {
 622     List rs = NIL;     /* possibly unboxed results     */
 623     List bs = NIL;     /* boxed results of wrapper     */
 624     List rbinds = NIL; /* bindings used to box results */
 625     StgExpr e   = NIL;
 626     Int i;
 627     for(i=0; reps[i] != '\0'; ++i) {
 628         StgRep k = mkStgRep(reps[i]);
 629         Cell v   = mkStgPrimVar(NIL,k,NIL);
 630         Name box = repToBox(reps[i]);
 631         if (isNull(box)) {
 632             bs = cons(v,bs);
 633         } else {
 634             StgRhs rhs = mkStgCon(box,singleton(v));
 635             StgVar bv = mkStgVar(rhs,NIL); /* boxed */
 636             bs     = cons(bv,bs);
 637             rbinds = cons(bv,rbinds);
 638         }
 639         rs = cons(v,rs);
 640     }
 641     /* Construct tuple of results */
 642     if (i == 1) {
 643         e = hd(bs);
 644     } else { /* includes i==0 case */
 645         StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
 646         rbinds = cons(r,rbinds);
 647         e = r;
 648     }
 649     /* construct result pair if needed */
 650     if (nonNull(state)) {
 651         /* Note that this builds a tuple directly - we know it's
 652          * saturated.
 653          */
 654         StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
 655         rbinds   = cons(r,rbinds);
 656         rs       = cons(state,rs);      /* last result is a state */
 657         e = r;
 658     }
 659     return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
 660 }
 661
 662 static List mkUnboxedVars( String reps )
 663 {
 664     List as = NIL;
 665     Int i;
 666     for(i=0; reps[i] != '\0'; ++i) {
 667         Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
 668         as = cons(v,as);
 669     }
 670     return rev(as);
 671 }
 672
 673 static List mkBoxedVars( String reps )
 674 {
 675     List as = NIL;
 676     Int i;
 677     for(i=0; reps[i] != '\0'; ++i) {
 678         as = cons(mkStgVar(NIL,NIL),as);
 679     }
 680     return rev(as);
 681 }
 682
 683 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
 684 {
 685     if (nonNull(b_args)) {
 686         StgVar b_arg = hd(b_args); /* boxed arg   */
 687         StgVar u_arg = hd(u_args); /* unboxed arg */
 688         //StgRep k     = mkStgRep(*reps);
 689         Name   box   = repToBox(*reps);
 690         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
 691         if (isNull(box)) {
 692             /* Use a trivial let-binding */
 693             stgVarBody(u_arg) = b_arg;
 694             return mkStgLet(singleton(u_arg),e);
 695         } else {
 696             StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
 697             return mkStgCase(b_arg,singleton(alt));
 698         }
 699     } else {
 700         return e;
 701     }
 702 }
 703
 704 /* Generate wrapper for primop based on list of arg types and result types:
 705  *
 706  * makeStgPrim op# False "II" "II" =
 707  *   \ x y -> "case x of { I# x# ->
 708  *             case y of { I# y# ->
 709  *             case op#{x#,y#} of { r1# r2# ->
 710  *             let r1 = I# r1#; r2 = I# r2# in
 711  *             (r1, r2)
 712  *             }}}"
 713  */
 714 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
 715 Name   op;
 716 Bool   addState;
 717 List   extra_args;
 718 String a_reps;
 719 String r_reps; {
 720     List b_args = NIL; /* boxed args to primop            */
 721     List u_args = NIL; /* possibly unboxed args to primop */
 722     List alts   = NIL;
 723     StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
 724     StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
 725
 726     /* box results */
 727     if (strcmp(r_reps,"B") == 0) {
 728         StgPrimAlt altF
 729            = mkStgPrimAlt(singleton(
 730                             mkStgPrimVar(mkInt(0),
 731                                          mkStgRep(INT_REP),NIL)
 732                           ),
 733                           nameFalse);
 734         StgPrimAlt altT
 735            = mkStgPrimAlt(
 736                 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
 737                 nameTrue);
 738         alts = doubleton(altF,altT);
 739         assert(nonNull(nameTrue));
 740         assert(!addState);
 741     } else {
 742         alts = singleton(boxResults(r_reps,s1));
 743     }
 744     b_args = mkBoxedVars(a_reps);
 745     u_args = mkUnboxedVars(a_reps);
 746     if (addState) {
 747         List actual_args
 748            = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
 749         StgRhs rhs
 750            = makeStgLambda(singleton(s0),
 751                            unboxVars(a_reps,b_args,u_args,
 752                                      mkStgPrimCase(mkStgPrim(op,actual_args),
 753                                                    alts)));
 754         StgVar m = mkStgVar(rhs,NIL);
 755         return makeStgLambda(b_args,
 756                              mkStgLet(singleton(m),
 757                                       mkStgApp(nameMkIO,singleton(m))));
 758     } else {
 759         List actual_args = appendOnto(extra_args,u_args);
 760         return makeStgLambda(
 761                   b_args,
 762                   unboxVars(a_reps,b_args,u_args,
 763                             mkStgPrimCase(mkStgPrim(op,actual_args),alts))
 764                );
 765     }
 766 }
 767
 768 Void implementPrim( n )
 769 Name n; {
 770     const AsmPrim* p = name(n).primop;
 771     StgRhs   rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
 772     StgVar   v   = mkStgVar(rhs,NIL);
 773     name(n).stgVar   = v;
 774     name(n).stgSize  = stgSize(stgVarBody(v));
 775     name(n).inlineMe = TRUE;
 776     stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 777 }
 778
 779 /* Generate wrapper code from (in,out) type lists.
 780  *
 781  * For example:
 782  *
 783  *     inTypes  = [Int,Float]
 784  *     outTypes = [Char,Addr]
 785  * ==>
 786  *     \ fun a1 a2 ->
 787  *       let m = (\ s0 ->
 788  *           case a1 of { I# a1# ->
 789  *           case s2 of { F# a2# ->
 790  *           case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
 791  *           let r1 = C# r1# in
 792  *           let r2 = A# r2# in
 793  *           let r  = (r1,r2) in
 794  *           (r,s1)
 795  *           }}})
 796  *       in primMkIO m
 797  *       ::
 798  *       Addr -> (Int -> Float -> IO (Char,Addr))
 799  */
 800 Void implementForeignImport( Name n )
 801 {
 802     Type t       = name(n).type;
 803     List argTys    = NIL;
 804     List resultTys = NIL;
 805     CFunDescriptor* descriptor = 0;
 806     Bool addState = TRUE;
 807     while (getHead(t)==typeArrow && argCount==2) {
 808         Type ta = fullExpand(arg(fun(t)));
 809         Type tr = arg(t);
 810         argTys = cons(ta,argTys);
 811         t = tr;
 812     }
 813     argTys = rev(argTys);
 814     if (getHead(t) == typeIO) {
 815         resultTys = getArgs(t);
 816         assert(length(resultTys) == 1);
 817         resultTys = hd(resultTys);
 818         addState = TRUE;
 819     } else {
 820         resultTys = t;
 821         addState = FALSE;
 822     }
 823     resultTys = fullExpand(resultTys);
 824     if (isTuple(getHead(resultTys))) {
 825         resultTys = getArgs(resultTys);
 826     } else if (getHead(resultTys) == typeUnit) {
 827         resultTys = NIL;
 828     } else {
 829         resultTys = singleton(resultTys);
 830     }
 831     mapOver(foreignArgTy,argTys);  /* allows foreignObj, byteArrays, etc */
 832     mapOver(foreignResultTy,resultTys); /* doesn't */
 833     descriptor = mkDescriptor(charListToString(argTys),
 834                               charListToString(resultTys));
 835     name(n).primop = addState ? &ccall_IO : &ccall_Id;
 836     {
 837         Pair    extName = name(n).defn;
 838         void*   funPtr  = getDLLSymbol(textToStr(textOf(fst(extName))),
 839                                        textToStr(textOf(snd(extName))));
 840         List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
 841         StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
 842                                  descriptor->result_tys);
 843         StgVar v   = mkStgVar(rhs,NIL);
 844         if (funPtr == 0) {
 845             ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
 846                 textToStr(textOf(snd(extName))),
 847                 textToStr(textOf(fst(extName)))
 848             EEND;
 849         }
 850         //ppStg(v);
 851         name(n).defn     = NIL;
 852         name(n).stgVar   = v;
 853         name(n).stgSize  = stgSize(stgVarBody(v));
 854         name(n).inlineMe = TRUE;
 855         stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
 856     }
 857 }
 858
 859 Void implementForeignExport( Name n )
 860 {
 861     internal("implementForeignExport: not implemented");
 862 }
 863
 864 // ToDo: figure out how to set inlineMe for these (non-Name) things
 865 Void implementTuple(size)
 866 Int size; {
 867     if (size > 0) {
 868         Cell    t    = mkTuple(size);
 869         List    args = makeArgs(size);
 870         StgVar  tv   = mkStgVar(mkStgCon(t,args),NIL);
 871         StgExpr e    = mkStgLet(singleton(tv),tv);
 872         StgVar  v    = mkStgVar(mkStgLambda(args,e),NIL);
 873         stgGlobals   = cons(pair(t,v),stgGlobals);   /* so we can see it */
 874     } else {
 875         StgVar  tv   = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
 876         stgGlobals   = cons(pair(nameUnit,tv),stgGlobals);      /* ditto */
 877     }
 878 }
 879
 880 /* --------------------------------------------------------------------------
 881  * Compiler control:
 882  * ------------------------------------------------------------------------*/
 883
 884 Void translateControl(what)
 885 Int what; {
 886     switch (what) {
 887     case INSTALL:
 888         {
 889             /* deliberate fall through */
 890         }
 891     case RESET:
 892             stgGlobals=NIL;
 893             break;
 894     case MARK:
 895             mark(stgGlobals);
 896             break;
 897     }
 898 }
 899
 900 /*-------------------------------------------------------------------------*/