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.8 $
  12  * $Date: 1999/10/15 11:02:35 $
  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 /* Outbound denotes data moving from Haskell world to elsewhere.
 538    Inbound denotes data moving from elsewhere to Haskell world.
 539 */
 540 static String  charListToString   ( List cs );
 541 static Cell    foreignTy          ( Bool outBound, Type t );
 542 static Cell    foreignOutboundTy  ( Type t );
 543 static Cell    foreignInboundTy   ( Type t );
 544 static Name    repToBox           ( char c );
 545 static StgRhs  makeStgPrim        ( Name,Bool,List,String,String );
 546
 547 static String charListToString( List cs )
 548 {
 549     static char s[100];
 550
 551     Int i = 0;
 552     assert( length(cs) < 100 );
 553     for(; nonNull(cs); ++i, cs=tl(cs)) {
 554         s[i] = charOf(hd(cs));
 555     }
 556     s[i] = '\0';
 557     return textToStr(findText(s));
 558 }
 559
 560 static Cell foreignTy ( Bool outBound, Type t )
 561 {
 562     if      (t == typeChar)   return mkChar(CHAR_REP);
 563     else if (t == typeInt)    return mkChar(INT_REP);
 564 #if 0
 565     else if (t == typeInteger)return mkChar(INTEGER_REP);
 566 #endif
 567     else if (t == typeWord)   return mkChar(WORD_REP);
 568     else if (t == typeAddr)   return mkChar(ADDR_REP);
 569     else if (t == typeFloat)  return mkChar(FLOAT_REP);
 570     else if (t == typeDouble) return mkChar(DOUBLE_REP);
 571 #ifdef PROVIDE_FOREIGN
 572     else if (t == typeForeign)return mkChar(FOREIGN_REP);
 573          /* ToDo: argty only! */
 574 #endif
 575 #if 0
 576     else if (t == typePrimByteArray) return mkChar(BARR_REP);
 577          /* ToDo: argty only! */
 578     else if (whatIs(t) == AP) {
 579         Type h = getHead(t);
 580         if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
 581          /* ToDo: argty only! */
 582     }
 583 #endif
 584    /* ToDo: decent line numbers! */
 585    if (outBound) {
 586       ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
 587       ERRTEXT " \"" ETHEN ERRTYPE(t);
 588       ERRTEXT "\""
 589       EEND;
 590    } else {
 591       ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
 592       ERRTEXT " \"" ETHEN ERRTYPE(t);
 593       ERRTEXT "\""
 594       EEND;
 595    }
 596 }
 597
 598 static Cell foreignOutboundTy ( Type t )
 599 {
 600     return foreignTy ( TRUE, t );
 601 }
 602
 603 static Cell foreignInboundTy ( Type t )
 604 {
 605     return foreignTy ( FALSE, t );
 606 }
 607
 608 static Name repToBox( char c )
 609 {
 610     switch (c) {
 611     case CHAR_REP:    return nameMkC;
 612     case INT_REP:     return nameMkI;
 613     case INTEGER_REP: return nameMkInteger;
 614     case WORD_REP:    return nameMkW;
 615     case ADDR_REP:    return nameMkA;
 616     case FLOAT_REP:   return nameMkF;
 617     case DOUBLE_REP:  return nameMkD;
 618     case ARR_REP:     return nameMkPrimArray;
 619     case BARR_REP:    return nameMkPrimByteArray;
 620     case REF_REP:     return nameMkRef;
 621     case MUTARR_REP:  return nameMkPrimMutableArray;
 622     case MUTBARR_REP: return nameMkPrimMutableByteArray;
 623     case STABLE_REP:  return nameMkStable;
 624 #ifdef PROVIDE_WEAK
 625     case WEAK_REP:  return nameMkWeak;
 626 #endif
 627 #ifdef PROVIDE_FOREIGN
 628     case FOREIGN_REP: return nameMkForeign;
 629 #endif
 630 #ifdef PROVIDE_CONCURRENT
 631     case THREADID_REP: return nameMkThreadId;
 632     case MVAR_REP:     return nameMkMVar;
 633 #endif
 634     default: return NIL;
 635     }
 636 }
 637
 638 static StgPrimAlt boxResults( String reps, StgVar state )
 639 {
 640     List rs = NIL;     /* possibly unboxed results     */
 641     List bs = NIL;     /* boxed results of wrapper     */
 642     List rbinds = NIL; /* bindings used to box results */
 643     StgExpr e   = NIL;
 644     Int i;
 645     for(i=0; reps[i] != '\0'; ++i) {
 646         StgRep k = mkStgRep(reps[i]);
 647         Cell v   = mkStgPrimVar(NIL,k,NIL);
 648         Name box = repToBox(reps[i]);
 649         if (isNull(box)) {
 650             bs = cons(v,bs);
 651         } else {
 652             StgRhs rhs = mkStgCon(box,singleton(v));
 653             StgVar bv = mkStgVar(rhs,NIL); /* boxed */
 654             bs     = cons(bv,bs);
 655             rbinds = cons(bv,rbinds);
 656         }
 657         rs = cons(v,rs);
 658     }
 659     /* Construct tuple of results */
 660     if (i == 1) {
 661         e = hd(bs);
 662     } else { /* includes i==0 case */
 663         StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
 664         rbinds = cons(r,rbinds);
 665         e = r;
 666     }
 667     /* construct result pair if needed */
 668     if (nonNull(state)) {
 669         /* Note that this builds a tuple directly - we know it's
 670          * saturated.
 671          */
 672         StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
 673         rbinds   = cons(r,rbinds);
 674         rs       = cons(state,rs);      /* last result is a state */
 675         e = r;
 676     }
 677     return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
 678 }
 679
 680 static List mkUnboxedVars( String reps )
 681 {
 682     List as = NIL;
 683     Int i;
 684     for(i=0; reps[i] != '\0'; ++i) {
 685         Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
 686         as = cons(v,as);
 687     }
 688     return rev(as);
 689 }
 690
 691 static List mkBoxedVars( String reps )
 692 {
 693     List as = NIL;
 694     Int i;
 695     for(i=0; reps[i] != '\0'; ++i) {
 696         as = cons(mkStgVar(NIL,NIL),as);
 697     }
 698     return rev(as);
 699 }
 700
 701 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
 702 {
 703     if (nonNull(b_args)) {
 704         StgVar b_arg = hd(b_args); /* boxed arg   */
 705         StgVar u_arg = hd(u_args); /* unboxed arg */
 706         //StgRep k     = mkStgRep(*reps);
 707         Name   box   = repToBox(*reps);
 708         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
 709         if (isNull(box)) {
 710             /* Use a trivial let-binding */
 711             stgVarBody(u_arg) = b_arg;
 712             return mkStgLet(singleton(u_arg),e);
 713         } else {
 714             StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
 715             return mkStgCase(b_arg,singleton(alt));
 716         }
 717     } else {
 718         return e;
 719     }
 720 }
 721
 722 /* Generate wrapper for primop based on list of arg types and result types:
 723  *
 724  * makeStgPrim op# False "II" "II" =
 725  *   \ x y -> "case x of { I# x# ->
 726  *             case y of { I# y# ->
 727  *             case op#{x#,y#} of { r1# r2# ->
 728  *             let r1 = I# r1#; r2 = I# r2# in
 729  *             (r1, r2)
 730  *             }}}"
 731  */
 732 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
 733 Name   op;
 734 Bool   addState;
 735 List   extra_args;
 736 String a_reps;
 737 String r_reps; {
 738     List b_args = NIL; /* boxed args to primop            */
 739     List u_args = NIL; /* possibly unboxed args to primop */
 740     List alts   = NIL;
 741     StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
 742     StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
 743
 744     /* box results */
 745     if (strcmp(r_reps,"B") == 0) {
 746         StgPrimAlt altF
 747            = mkStgPrimAlt(singleton(
 748                             mkStgPrimVar(mkInt(0),
 749                                          mkStgRep(INT_REP),NIL)
 750                           ),
 751                           nameFalse);
 752         StgPrimAlt altT
 753            = mkStgPrimAlt(
 754                 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
 755                 nameTrue);
 756         alts = doubleton(altF,altT);
 757         assert(nonNull(nameTrue));
 758         assert(!addState);
 759     } else {
 760         alts = singleton(boxResults(r_reps,s1));
 761     }
 762     b_args = mkBoxedVars(a_reps);
 763     u_args = mkUnboxedVars(a_reps);
 764     if (addState) {
 765         List actual_args
 766            = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
 767         StgRhs rhs
 768            = makeStgLambda(singleton(s0),
 769                            unboxVars(a_reps,b_args,u_args,
 770                                      mkStgPrimCase(mkStgPrim(op,actual_args),
 771                                                    alts)));
 772         StgVar m = mkStgVar(rhs,NIL);
 773         return makeStgLambda(b_args,
 774                              mkStgLet(singleton(m),
 775                                       mkStgApp(nameMkIO,singleton(m))));
 776     } else {
 777         List actual_args = appendOnto(extra_args,u_args);
 778         return makeStgLambda(
 779                   b_args,
 780                   unboxVars(a_reps,b_args,u_args,
 781                             mkStgPrimCase(mkStgPrim(op,actual_args),alts))
 782                );
 783     }
 784 }
 785
 786 Void implementPrim ( n )
 787 Name n; {
 788     const AsmPrim* p = name(n).primop;
 789     StgRhs   rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
 790     StgVar   v   = mkStgVar(rhs,NIL);
 791     name(n).stgVar   = v;
 792     name(n).stgSize  = stgSize(stgVarBody(v));
 793     name(n).inlineMe = TRUE;
 794     stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 795 }
 796
 797 /* Generate wrapper code from (in,out) type lists.
 798  *
 799  * For example:
 800  *
 801  *     inTypes  = [Int,Float]
 802  *     outTypes = [Char,Addr]
 803  * ==>
 804  *     \ fun a1 a2 ->
 805  *       let m = (\ s0 ->
 806  *           case a1 of { I# a1# ->
 807  *           case s2 of { F# a2# ->
 808  *           case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
 809  *           let r1 = C# r1# in
 810  *           let r2 = A# r2# in
 811  *           let r  = (r1,r2) in
 812  *           (r,s1)
 813  *           }}})
 814  *       in primMkIO m
 815  *       ::
 816  *       Addr -> (Int -> Float -> IO (Char,Addr))
 817  */
 818 Void implementForeignImport ( Name n )
 819 {
 820     Type t         = name(n).type;
 821     List argTys    = NIL;
 822     List resultTys = NIL;
 823     CFunDescriptor* descriptor = 0;
 824     Bool addState = TRUE;
 825     while (getHead(t)==typeArrow && argCount==2) {
 826         Type ta = fullExpand(arg(fun(t)));
 827         Type tr = arg(t);
 828         argTys = cons(ta,argTys);
 829         t = tr;
 830     }
 831     argTys = rev(argTys);
 832     if (getHead(t) == typeIO) {
 833         resultTys = getArgs(t);
 834         assert(length(resultTys) == 1);
 835         resultTys = hd(resultTys);
 836         addState = TRUE;
 837     } else {
 838         resultTys = t;
 839         addState = FALSE;
 840     }
 841     resultTys = fullExpand(resultTys);
 842     if (isTuple(getHead(resultTys))) {
 843         resultTys = getArgs(resultTys);
 844     } else if (getHead(resultTys) == typeUnit) {
 845         resultTys = NIL;
 846     } else {
 847         resultTys = singleton(resultTys);
 848     }
 849     mapOver(foreignOutboundTy,argTys);  /* allows foreignObj, byteArrays, etc */
 850     mapOver(foreignInboundTy,resultTys); /* doesn't */
 851     descriptor = mkDescriptor(charListToString(argTys),
 852                               charListToString(resultTys));
 853     name(n).primop = addState ? &ccall_IO : &ccall_Id;
 854     {
 855         Pair    extName = name(n).defn;
 856         void*   funPtr  = getDLLSymbol(textToStr(textOf(fst(extName))),
 857                                        textToStr(textOf(snd(extName))));
 858         List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
 859         StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
 860                                  descriptor->result_tys);
 861         StgVar v   = mkStgVar(rhs,NIL);
 862         if (funPtr == 0) {
 863             ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
 864                 textToStr(textOf(snd(extName))),
 865                 textToStr(textOf(fst(extName)))
 866             EEND;
 867         }
 868         /* ppStg(v); */
 869         name(n).defn     = NIL;
 870         name(n).stgVar   = v;
 871         name(n).stgSize  = stgSize(stgVarBody(v));
 872         name(n).inlineMe = TRUE;
 873         stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
 874     }
 875 }
 876
 877
 878 /* Generate code:
 879  *
 880  * \ fun s0 ->
 881      let e1 = A# "...."
 882      in  primMkAdjThunk fun s0 e1
 883
 884    we require, and check that,
 885      fun :: prim_arg* -> IO prim_result
 886  */
 887 Void implementForeignExport ( Name n )
 888 {
 889     Type t         = name(n).type;
 890     List argTys    = NIL;
 891     List resultTys = NIL;
 892
 893     if (getHead(t)==typeArrow && argCount==2) {
 894        t = arg(fun(t));
 895     } else {
 896         ERRMSG(0) "foreign export has illegal type" ETHEN
 897         ERRTEXT " \"" ETHEN ERRTYPE(t);
 898         ERRTEXT "\""
 899         EEND;
 900     }
 901
 902     while (getHead(t)==typeArrow && argCount==2) {
 903         Type ta = fullExpand(arg(fun(t)));
 904         Type tr = arg(t);
 905         argTys = cons(ta,argTys);
 906         t = tr;
 907     }
 908     argTys = rev(argTys);
 909     if (getHead(t) == typeIO) {
 910         resultTys = getArgs(t);
 911         assert(length(resultTys) == 1);
 912         resultTys = hd(resultTys);
 913     } else {
 914         ERRMSG(0) "foreign export doesn't return an IO type" ETHEN
 915         ERRTEXT " \"" ETHEN ERRTYPE(t);
 916         ERRTEXT "\""
 917         EEND;
 918     }
 919     resultTys = fullExpand(resultTys);
 920
 921     mapOver(foreignInboundTy,argTys);
 922
 923     {
 924     List     tdList;
 925     Text     tdText;
 926     List     args;
 927     StgVar   e1, e2, v;
 928     StgExpr  fun;
 929
 930     tdList = cons(mkChar(':'),argTys);
 931     if (resultTys != typeUnit)
 932        tdList = cons(foreignOutboundTy(resultTys),tdList);
 933
 934     tdText = findText(charListToString ( tdList ));
 935     args   = makeArgs(2);
 936     e1     = mkStgVar(
 937                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
 938                 NIL
 939              );
 940      e2    = mkStgVar(
 941                 mkStgApp(nameUnpackString,singleton(e1)),
 942                 NIL
 943              );
 944
 945     fun    = mkStgLambda(
 946                 args,
 947                 mkStgLet(
 948                    doubleton(e1,e2),
 949                    mkStgApp(
 950                       nameCreateAdjThunk,
 951                       tripleton(hd(args),e2,hd(tl(args)))
 952                    )
 953                 )
 954              );
 955
 956     v = mkStgVar(fun,NIL);
 957     /* ppStg(v); */
 958
 959     name(n).defn     = NIL;
 960     name(n).stgVar   = v;
 961     name(n).stgSize  = stgSize(stgVarBody(v));
 962     name(n).inlineMe = FALSE;
 963     stgGlobals       = cons(pair(n,v),stgGlobals);
 964     }
 965 }
 966
 967 // ToDo: figure out how to set inlineMe for these (non-Name) things
 968 Void implementTuple(size)
 969 Int size; {
 970     if (size > 0) {
 971         Cell    t    = mkTuple(size);
 972         List    args = makeArgs(size);
 973         StgVar  tv   = mkStgVar(mkStgCon(t,args),NIL);
 974         StgExpr e    = mkStgLet(singleton(tv),tv);
 975         StgVar  v    = mkStgVar(mkStgLambda(args,e),NIL);
 976         stgGlobals   = cons(pair(t,v),stgGlobals);   /* so we can see it */
 977     } else {
 978         StgVar  tv   = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
 979         stgGlobals   = cons(pair(nameUnit,tv),stgGlobals);      /* ditto */
 980     }
 981 }
 982
 983 /* --------------------------------------------------------------------------
 984  * Compiler control:
 985  * ------------------------------------------------------------------------*/
 986
 987 Void translateControl(what)
 988 Int what; {
 989     switch (what) {
 990     case INSTALL:
 991         {
 992             /* deliberate fall through */
 993         }
 994     case RESET:
 995             stgGlobals=NIL;
 996             break;
 997     case MARK:
 998             mark(stgGlobals);
 999             break;
1000     }
1001 }
1002
1003 /*-------------------------------------------------------------------------*/