ghc/interpreter/translate.c

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