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