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.20 $
  14  * $Date: 1999/11/29 18:53:15 $
  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         {
 207             Triple nc    = snd(e);
 208             Offset o     = fst3(nc);
 209             Cell   discr = snd3(nc);
 210             Cell   r     = thd3(nc);
 211             Cell   scrut = stgOffset(o,sc);
 212             Cell   h     = getHead(discr);
 213             Int    da    = discrArity(discr);
 214             char   str[30];
 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
 238                 /* box number */
 239                 sprintf(str, "%d", n);
 240                 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
 241                 binds = cons(n,binds);
 242
 243                 /* coerce number to right type (using Integral dict) */
 244                 n = mkStgVar(mkStgApp(
 245                        namePmFromInteger,doubleton(dIntegral,n)),NIL);
 246                 binds = cons(n,binds);
 247
 248                 ++co;
 249                 v = mkStgVar(mkStgApp(
 250                        namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
 251                 return
 252                    mkStgLet(
 253                       binds,
 254                       makeStgIf(
 255                          mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
 256                          mkStgLet(singleton(v),
 257                                   stgExpr(r,
 258                                           co,
 259                                           cons(pair(mkOffset(co),v),sc),
 260                                           failExpr)),
 261                          failExpr));
 262             }
 263 #endif /* NPLUSK */
 264
 265             assert(isName(h) && argCount == 2);
 266             {
 267                 /* This code is rather ugly.
 268                  * We ought to desugar it using one of the following:
 269                  *   if (==) dEq (fromInt     dNum        pat) scrut
 270                  *   if (==) dEq (fromInteger dNum        pat) scrut
 271                  *   if (==) dEq (fromFloat   dFractional pat) scrut
 272                  * But it would be very hard to obtain the Eq dictionary
 273                  * from the Num or Fractional dictionary we have.
 274                  * Instead, we rely on the Prelude to supply 3 helper
 275                  * functions which do the test for us.
 276                  *   primPmInt     :: Num a => Int -> a -> Bool
 277                  *   primPmInteger :: Num a => Integer -> a -> Bool
 278                  *   primPmDouble  :: Fractional a => Double -> a -> Bool
 279                  */
 280                 Cell   n      = arg(discr);
 281                 Cell   dict   = arg(fun(discr));
 282                 StgExpr d     = NIL;
 283                 List    binds = NIL;
 284                 //StgExpr m     = NIL;
 285                 Name   box
 286                     = h == nameFromInt     ? nameMkI
 287                     : h == nameFromInteger ? nameMkInteger
 288                     :                        nameMkD;
 289                 Name   testFun
 290                     = h == nameFromInt     ? namePmInt
 291                     : h == nameFromInteger ? namePmInteger
 292                     :                        namePmDouble;
 293                 Cell   altsc  = sc;
 294                 Cell   vs     = NIL;
 295                 Int    i;
 296
 297                 for(i=1; i<=da; ++i) {
 298                     Cell nv = mkStgVar(NIL,NIL);
 299                     vs    = cons(nv,vs);
 300                     altsc = cons(pair(mkOffset(co+i),nv),altsc);
 301                 }
 302                 /* bind dictionary */
 303                 d = stgRhs(dict,co,sc,namePMFail);
 304                 if (!isAtomic(d)) { /* wasn't atomic */
 305                     d = mkStgVar(d,NIL);
 306                     binds = cons(d,binds);
 307                 }
 308                 /* bind number */
 309                 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
 310                 binds = cons(n,binds);
 311
 312                 return
 313                    makeStgIf(
 314                       mkStgLet(binds,
 315                                mkStgApp(testFun,tripleton(d,n,scrut))),
 316                       stgExpr(r,co+da,altsc,failExpr),
 317                       failExpr
 318                    );
 319             }
 320         }
 321
 322     case LETREC:
 323         {
 324             List binds = NIL;
 325             List vs = NIL;
 326             List bs;
 327             /* allocate variables, extend scope */
 328             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 329                 Cell nv  = mkStgVar(NIL,NIL);
 330                 sc = cons(pair(fst3(hd(bs)),nv),sc);
 331                 binds = cons(nv,binds);
 332                 vs = cons(nv,vs);
 333             }
 334             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 335                 Cell nv  = mkStgVar(NIL,NIL);
 336                 sc = cons(pair(mkOffset(++co),nv),sc);
 337                 binds = cons(nv,binds);
 338                 vs = cons(nv,vs);
 339             }
 340             vs = rev(vs);
 341             /* transform functions */
 342             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 343                 Cell fun = hd(bs);
 344                 Cell nv  = hd(vs);
 345                 List as = NIL;
 346                 List funsc = sc;
 347                 Int  arity = intOf(snd3(fun));
 348                 Int  i;
 349                 for(i=1; i<=arity; ++i) {
 350                     Cell v = mkStgVar(NIL,NIL);
 351                     as = cons(v,as);
 352                     funsc = cons(pair(mkOffset(co+i),v),funsc);
 353                 }
 354                 stgVarBody(nv)
 355                    = mkStgLambda(
 356                         as,
 357                         stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
 358             }
 359             /* transform expressions */
 360             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 361                 Cell rhs = hd(bs);
 362                 Cell nv  = hd(vs);
 363                 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
 364             }
 365             return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
 366         }
 367
 368     default: /* convert to an StgApp or StgVar plus some bindings */
 369         {
 370             List args  = NIL;
 371             List binds = NIL;
 372             List as    = NIL;
 373
 374             /* Unwind args */
 375             while (isAp(e)) {
 376                 Cell arg = arg(e);
 377                 e        = fun(e);
 378                 args = cons(arg,args);
 379             }
 380
 381             /* Special cases */
 382             if (e == nameSel && length(args) == 3) {
 383                 Cell   con   = hd(args);
 384                 StgExpr v    = stgExpr(hd(tl(args)),co,sc,namePMFail);
 385                 Int    ix    = intOf(hd(tl(tl(args))));
 386                 Int    da    = discrArity(con);
 387                 List   vs    = NIL;
 388                 Int    i;
 389                 for(i=1; i<=da; ++i) {
 390                     Cell nv = mkStgVar(NIL,NIL);
 391                     vs=cons(nv,vs);
 392                 }
 393                 return
 394                    mkStgCase(v,
 395                              doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
 396                              mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
 397             }
 398
 399             /* Arguments must be StgAtoms */
 400             for(as=args; nonNull(as); as=tl(as)) {
 401                 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
 402                 if (whatIs(a) == LETREC) {
 403                     binds = appendOnto(stgLetBinds(a),binds);
 404                     a = stgLetBody(a);
 405                 }
 406                 if (!isAtomic(a)) {
 407                     a     = mkStgVar(a,NIL);
 408                     binds = cons(a,binds);
 409                 }
 410                 hd(as) = a;
 411             }
 412
 413             /* Special case: saturated constructor application */
 414             if (isName(e) && isCfun(e)
 415                 && name(e).arity > 0
 416                 && name(e).arity == length(args)) {
 417                StgVar v;
 418                /* fprintf ( stderr, "saturated application of %s\n",
 419                                     textToStr(name(e).text)); */
 420                v = mkStgVar(mkStgCon(e,args),NIL);
 421                binds = cons(v,binds);
 422                return mkStgLet(binds,v);
 423
 424
 425             }
 426
 427             /* Function must be StgVar or Name */
 428             e = stgRhs(e,co,sc,namePMFail);
 429             if (!isStgVar(e) && !isName(e)) {
 430                 e = mkStgVar(e,NIL);
 431                 binds = cons(e,binds);
 432             }
 433
 434             return makeStgLet(binds,makeStgApp(e,args));
 435         }
 436     }
 437 }
 438
 439 #if 0 /* apparently not used */
 440 static Void ppExp( Name n, Int arity, Cell e )
 441 {
 442     if (1 || debugCode) {
 443         Int i;
 444         printf("%s", textToStr(name(n).text));
 445         for (i = arity; i > 0; i--) {
 446             printf(" o%d", i);
 447         }
 448         printf(" = ");
 449         printExp(stdout,e);
 450         printf("\n");
 451     }
 452 }
 453 #endif
 454
 455
 456 Void stgDefn( Name n, Int arity, Cell e )
 457 {
 458     List vs = NIL;
 459     List sc = NIL;
 460     Int i, s;
 461     for (i = 1; i <= arity; ++i) {
 462         Cell nv = mkStgVar(NIL,NIL);
 463         vs = cons(nv,vs);
 464         sc = cons(pair(mkOffset(i),nv),sc);
 465     }
 466     stgVarBody(name(n).stgVar)
 467        = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
 468 }
 469
 470 Void implementCfun(c,scs)               /* Build implementation for constr */
 471 Name c;                                 /* fun c.  scs lists integers (1..)*/
 472 List scs; {                             /* in incr order of strict comps.  */
 473     Int a = name(c).arity;
 474
 475     if (a > 0) {
 476         StgVar  vcurr, e1, v, vsi;
 477         List    args  = makeArgs(a);
 478         StgVar  v0    = mkStgVar(mkStgCon(c,args),NIL);
 479         List    binds = singleton(v0);
 480
 481         vcurr = v0;
 482         for (; nonNull(scs); scs=tl(scs)) {
 483            vsi   = nth(intOf(hd(scs))-1,args);
 484            vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
 485            binds = cons(vcurr,binds);
 486         }
 487         binds = rev(binds);
 488         e1    = mkStgLet(binds,vcurr);
 489         v     = mkStgVar(mkStgLambda(args,e1),NIL);
 490         name(c).stgVar = v;
 491     } else {
 492         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
 493         name(c).stgVar = v;
 494     }
 495     stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
 496     /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
 497 }
 498
 499 /* --------------------------------------------------------------------------
 500  * Foreign function calls and primops
 501  * ------------------------------------------------------------------------*/
 502
 503 /* Outbound denotes data moving from Haskell world to elsewhere.
 504    Inbound denotes data moving from elsewhere to Haskell world.
 505 */
 506 static String  charListToString   ( List cs );
 507 static Cell    foreignTy          ( Bool outBound, Type t );
 508 static Cell    foreignOutboundTy  ( Type t );
 509 static Cell    foreignInboundTy   ( Type t );
 510 static Name    repToBox           ( char c );
 511 static StgRhs  makeStgPrim        ( Name,Bool,List,String,String );
 512
 513 static String charListToString( List cs )
 514 {
 515     static char s[100];
 516
 517     Int i = 0;
 518     assert( length(cs) < 100 );
 519     for(; nonNull(cs); ++i, cs=tl(cs)) {
 520         s[i] = charOf(hd(cs));
 521     }
 522     s[i] = '\0';
 523     return textToStr(findText(s));
 524 }
 525
 526 static Cell foreignTy ( Bool outBound, Type t )
 527 {
 528     if      (t == typeChar)   return mkChar(CHAR_REP);
 529     else if (t == typeInt)    return mkChar(INT_REP);
 530 #if 0
 531     else if (t == typeInteger)return mkChar(INTEGER_REP);
 532 #endif
 533     else if (t == typeWord)   return mkChar(WORD_REP);
 534     else if (t == typeAddr)   return mkChar(ADDR_REP);
 535     else if (t == typeFloat)  return mkChar(FLOAT_REP);
 536     else if (t == typeDouble) return mkChar(DOUBLE_REP);
 537     else if (t == typeStable) return mkChar(STABLE_REP);
 538 #ifdef PROVIDE_FOREIGN
 539     else if (t == typeForeign)return mkChar(FOREIGN_REP);
 540          /* ToDo: argty only! */
 541 #endif
 542 #if 0
 543     else if (t == typePrimByteArray) return mkChar(BARR_REP);
 544          /* ToDo: argty only! */
 545     else if (whatIs(t) == AP) {
 546         Type h = getHead(t);
 547         if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
 548          /* ToDo: argty only! */
 549     }
 550 #endif
 551    /* ToDo: decent line numbers! */
 552    if (outBound) {
 553       ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
 554       ERRTEXT " \"" ETHEN ERRTYPE(t);
 555       ERRTEXT "\""
 556       EEND;
 557    } else {
 558       ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
 559       ERRTEXT " \"" ETHEN ERRTYPE(t);
 560       ERRTEXT "\""
 561       EEND;
 562    }
 563 }
 564
 565 static Cell foreignOutboundTy ( Type t )
 566 {
 567     return foreignTy ( TRUE, t );
 568 }
 569
 570 static Cell foreignInboundTy ( Type t )
 571 {
 572     return foreignTy ( FALSE, t );
 573 }
 574
 575 static Name repToBox( char c )
 576 {
 577     switch (c) {
 578     case CHAR_REP:     return nameMkC;
 579     case INT_REP:      return nameMkI;
 580     case INTEGER_REP:  return nameMkInteger;
 581     case WORD_REP:     return nameMkW;
 582     case ADDR_REP:     return nameMkA;
 583     case FLOAT_REP:    return nameMkF;
 584     case DOUBLE_REP:   return nameMkD;
 585     case ARR_REP:      return nameMkPrimArray;
 586     case BARR_REP:     return nameMkPrimByteArray;
 587     case REF_REP:      return nameMkRef;
 588     case MUTARR_REP:   return nameMkPrimMutableArray;
 589     case MUTBARR_REP:  return nameMkPrimMutableByteArray;
 590     case STABLE_REP:   return nameMkStable;
 591     case THREADID_REP: return nameMkThreadId;
 592     case MVAR_REP:     return nameMkPrimMVar;
 593 #ifdef PROVIDE_WEAK
 594     case WEAK_REP:  return nameMkWeak;
 595 #endif
 596 #ifdef PROVIDE_FOREIGN
 597     case FOREIGN_REP: return nameMkForeign;
 598 #endif
 599     default: return NIL;
 600     }
 601 }
 602
 603 static StgPrimAlt boxResults( String reps, StgVar state )
 604 {
 605     List rs = NIL;     /* possibly unboxed results     */
 606     List bs = NIL;     /* boxed results of wrapper     */
 607     List rbinds = NIL; /* bindings used to box results */
 608     StgExpr e   = NIL;
 609     Int i;
 610     for(i=0; reps[i] != '\0'; ++i) {
 611         StgRep k = mkStgRep(reps[i]);
 612         Cell v   = mkStgPrimVar(NIL,k,NIL);
 613         Name box = repToBox(reps[i]);
 614         if (isNull(box)) {
 615             bs = cons(v,bs);
 616         } else {
 617             StgRhs rhs = mkStgCon(box,singleton(v));
 618             StgVar bv = mkStgVar(rhs,NIL); /* boxed */
 619             bs     = cons(bv,bs);
 620             rbinds = cons(bv,rbinds);
 621         }
 622         rs = cons(v,rs);
 623     }
 624
 625     /* Construct tuple of results */
 626     if (i == 0) {
 627         e = nameUnit;
 628     } else
 629     if (i == 1) {
 630         e = hd(bs);
 631     } else {
 632         StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
 633         rbinds = cons(r,rbinds);
 634         e = r;
 635     }
 636     /* construct result pair if needed */
 637     if (nonNull(state)) {
 638         /* Note that this builds a tuple directly - we know it's
 639          * saturated.
 640          */
 641         StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
 642         rbinds   = cons(r,rbinds);
 643         rs       = cons(state,rs);      /* last result is a state */
 644         e = r;
 645     }
 646     return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
 647 }
 648
 649 static List mkUnboxedVars( String reps )
 650 {
 651     List as = NIL;
 652     Int i;
 653     for(i=0; reps[i] != '\0'; ++i) {
 654         Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
 655         as = cons(v,as);
 656     }
 657     return rev(as);
 658 }
 659
 660 static List mkBoxedVars( String reps )
 661 {
 662     List as = NIL;
 663     Int i;
 664     for(i=0; reps[i] != '\0'; ++i) {
 665         as = cons(mkStgVar(NIL,NIL),as);
 666     }
 667     return rev(as);
 668 }
 669
 670 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
 671 {
 672     if (nonNull(b_args)) {
 673         StgVar b_arg = hd(b_args); /* boxed arg   */
 674         StgVar u_arg = hd(u_args); /* unboxed arg */
 675         Name   box   = repToBox(*reps);
 676         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
 677         if (isNull(box)) {
 678             /* Use a trivial let-binding */
 679             stgVarBody(u_arg) = b_arg;
 680             return mkStgLet(singleton(u_arg),e);
 681         } else {
 682             StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
 683             return mkStgCase(b_arg,singleton(alt));
 684         }
 685     } else {
 686         return e;
 687     }
 688 }
 689
 690 /* Generate wrapper for primop based on list of arg types and result types:
 691  *
 692  * makeStgPrim op# False "II" "II" =
 693  *   \ x y -> "case x of { I# x# ->
 694  *             case y of { I# y# ->
 695  *             case op#{x#,y#} of { r1# r2# ->
 696  *             let r1 = I# r1#; r2 = I# r2# in
 697  *             (r1, r2)
 698  *             }}}"
 699  */
 700 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
 701 Name   op;
 702 Bool   addState;
 703 List   extra_args;
 704 String a_reps;
 705 String r_reps; {
 706     List b_args = NIL; /* boxed args to primop            */
 707     List u_args = NIL; /* possibly unboxed args to primop */
 708     List alts   = NIL;
 709     StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
 710     StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
 711
 712     /* box results */
 713     if (strcmp(r_reps,"B") == 0) {
 714         StgPrimAlt altF
 715            = mkStgPrimAlt(singleton(
 716                             mkStgPrimVar(mkInt(0),
 717                                          mkStgRep(INT_REP),NIL)
 718                           ),
 719                           nameFalse);
 720         StgPrimAlt altT
 721            = mkStgPrimAlt(
 722                 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
 723                 nameTrue);
 724         alts = doubleton(altF,altT);
 725         assert(nonNull(nameTrue));
 726         assert(!addState);
 727     } else {
 728         alts = singleton(boxResults(r_reps,s1));
 729     }
 730     b_args = mkBoxedVars(a_reps);
 731     u_args = mkUnboxedVars(a_reps);
 732     if (addState) {
 733         List actual_args
 734            = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
 735         StgRhs rhs
 736            = makeStgLambda(singleton(s0),
 737                            unboxVars(a_reps,b_args,u_args,
 738                                      mkStgPrimCase(mkStgPrim(op,actual_args),
 739                                                    alts)));
 740         StgVar m = mkStgVar(rhs,NIL);
 741         return makeStgLambda(b_args,
 742                              mkStgLet(singleton(m),
 743                                       mkStgApp(nameMkIO,singleton(m))));
 744     } else {
 745         List actual_args = appendOnto(extra_args,u_args);
 746         return makeStgLambda(
 747                   b_args,
 748                   unboxVars(a_reps,b_args,u_args,
 749                             mkStgPrimCase(mkStgPrim(op,actual_args),alts))
 750                );
 751     }
 752 }
 753
 754 Void implementPrim ( n )
 755 Name n; {
 756     const AsmPrim* p = name(n).primop;
 757     StgRhs   rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
 758     StgVar   v   = mkStgVar(rhs,NIL);
 759     name(n).stgVar   = v;
 760     stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 761 }
 762
 763 /* Generate wrapper code from (in,out) type lists.
 764  *
 765  * For example:
 766  *
 767  *     inTypes  = [Int,Float]
 768  *     outTypes = [Char,Addr]
 769  * ==>
 770  *     \ fun a1 a2 ->
 771  *       let m = (\ s0 ->
 772  *           case a1 of { I# a1# ->
 773  *           case s2 of { F# a2# ->
 774  *           case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
 775  *           let r1 = C# r1# in
 776  *           let r2 = A# r2# in
 777  *           let r  = (r1,r2) in
 778  *           (r,s1)
 779  *           }}})
 780  *       in primMkIO m
 781  *       ::
 782  *       Addr -> (Int -> Float -> IO (Char,Addr))
 783  */
 784 Void implementForeignImport ( Name n )
 785 {
 786     Type t         = name(n).type;
 787     List argTys    = NIL;
 788     List resultTys = NIL;
 789     CFunDescriptor* descriptor = 0;
 790     Bool addState  = TRUE;
 791     Bool dynamic   = isNull(name(n).defn);
 792     while (getHead(t)==typeArrow && argCount==2) {
 793         Type ta = fullExpand(arg(fun(t)));
 794         Type tr = arg(t);
 795         argTys = cons(ta,argTys);
 796         t = tr;
 797     }
 798     argTys = rev(argTys);
 799
 800     /* argTys now holds the argument tys.  If this is a dynamic call,
 801        the first one had better be an Addr.
 802     */
 803     if (dynamic) {
 804        if (isNull(argTys) || hd(argTys) != typeAddr) {
 805           ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
 806           EEND;
 807        }
 808     }
 809
 810     if (getHead(t) == typeIO) {
 811         resultTys = getArgs(t);
 812         assert(length(resultTys) == 1);
 813         resultTys = hd(resultTys);
 814         addState = TRUE;
 815     } else {
 816         resultTys = t;
 817         addState = FALSE;
 818     }
 819     resultTys = fullExpand(resultTys);
 820     if (isTuple(getHead(resultTys))) {
 821         resultTys = getArgs(resultTys);
 822     } else if (getHead(resultTys) == typeUnit) {
 823         resultTys = NIL;
 824     } else {
 825         resultTys = singleton(resultTys);
 826     }
 827     mapOver(foreignOutboundTy,argTys);  /* allows foreignObj, byteArrays, etc */
 828     mapOver(foreignInboundTy,resultTys); /* doesn't */
 829     descriptor
 830        = mkDescriptor(charListToString(argTys),
 831                       charListToString(resultTys));
 832     if (!descriptor) {
 833        ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
 834        EEND;
 835     }
 836
 837     /* ccall is the default convention, if it wasn't specified */
 838     if (isNull(name(n).callconv)
 839         || name(n).callconv == textCcall) {
 840        name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
 841     }
 842     else if (name(n).callconv == textStdcall) {
 843        if (!stdcallAllowed()) {
 844           ERRMSG(name(n).line) "stdcall is not supported on this platform"
 845           EEND;
 846        }
 847        name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
 848     }
 849     else
 850        internal ( "implementForeignImport: unknown calling convention");
 851
 852     {
 853         Pair   extName;
 854         void*  funPtr;
 855         List   extra_args;
 856         StgRhs rhs;
 857         StgVar v;
 858
 859         if (dynamic) {
 860            funPtr     = NULL;
 861            extra_args = singleton(mkPtr(descriptor));
 862            /* and we know that the first arg will be the function pointer */
 863         } else {
 864            extName = name(n).defn;
 865            funPtr  = getDLLSymbol(name(n).line,
 866                                   textToStr(textOf(fst(extName))),
 867                                   textToStr(textOf(snd(extName))));
 868            if (funPtr == 0) {
 869                ERRMSG(name(n).line)
 870                    "Could not find foreign function \"%s\" in \"%s\"",
 871                    textToStr(textOf(snd(extName))),
 872                    textToStr(textOf(fst(extName)))
 873                EEND;
 874            }
 875            extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
 876         }
 877
 878         rhs              = makeStgPrim(n,addState,extra_args,
 879                                        descriptor->arg_tys,
 880                                        descriptor->result_tys);
 881         v                = mkStgVar(rhs,NIL);
 882         name(n).defn     = NIL;
 883         name(n).stgVar   = v;
 884         stgGlobals       = cons(pair(n,v),stgGlobals);
 885     }
 886
 887     /* At this point the descriptor contains a tags for all args,
 888        because that makes makeStgPrim generate the correct unwrap
 889        code.  From now on, the descriptor is only used at the time
 890        the actual ccall is made.  So we need to zap the leading
 891        addr arg IF this is a f-i-dynamic call.
 892     */
 893     if (dynamic) {
 894        descriptor->arg_tys++;
 895        descriptor->num_args--;
 896     }
 897
 898
 899 }
 900
 901
 902 /* Generate code:
 903  *
 904  * \ fun s0 ->
 905      let e1 = A# "...."
 906          e3 = C# 'c' -- (ccall), or 's' (stdcall)
 907      in  primMkAdjThunk fun e1 e3 s0
 908
 909    we require, and check that,
 910      fun :: prim_arg* -> IO prim_result
 911  */
 912 Void implementForeignExport ( Name n )
 913 {
 914     Type t         = name(n).type;
 915     List argTys    = NIL;
 916     List resultTys = NIL;
 917     Char cc_char;
 918
 919     if (getHead(t)==typeArrow && argCount==2) {
 920        t = arg(fun(t));
 921     } else {
 922         ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
 923         ERRTEXT " \"" ETHEN ERRTYPE(t);
 924         ERRTEXT "\""
 925         EEND;
 926     }
 927
 928     while (getHead(t)==typeArrow && argCount==2) {
 929         Type ta = fullExpand(arg(fun(t)));
 930         Type tr = arg(t);
 931         argTys = cons(ta,argTys);
 932         t = tr;
 933     }
 934     argTys = rev(argTys);
 935     if (getHead(t) == typeIO) {
 936         resultTys = getArgs(t);
 937         assert(length(resultTys) == 1);
 938         resultTys = hd(resultTys);
 939     } else {
 940         ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
 941         ERRTEXT " \"" ETHEN ERRTYPE(t);
 942         ERRTEXT "\""
 943         EEND;
 944     }
 945     resultTys = fullExpand(resultTys);
 946
 947     mapOver(foreignInboundTy,argTys);
 948
 949     /* ccall is the default convention, if it wasn't specified */
 950     if (isNull(name(n).callconv)
 951         || name(n).callconv == textCcall) {
 952         cc_char = 'c';
 953     }
 954     else if (name(n).callconv == textStdcall) {
 955        if (!stdcallAllowed()) {
 956           ERRMSG(name(n).line) "stdcall is not supported on this platform"
 957           EEND;
 958        }
 959        cc_char = 's';
 960     }
 961     else
 962        internal ( "implementForeignExport: unknown calling convention");
 963
 964
 965     {
 966     List     tdList;
 967     Text     tdText;
 968     List     args;
 969     StgVar   e1, e2, e3, v;
 970     StgExpr  fun;
 971
 972     tdList = cons(mkChar(':'),argTys);
 973     if (resultTys != typeUnit)
 974        tdList = cons(foreignOutboundTy(resultTys),tdList);
 975
 976     tdText = findText(charListToString ( tdList ));
 977     args   = makeArgs(2);
 978     e1     = mkStgVar(
 979                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
 980                 NIL
 981              );
 982     e2     = mkStgVar(
 983                 mkStgApp(nameUnpackString,singleton(e1)),
 984                 NIL
 985              );
 986     e3     = mkStgVar(
 987                 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
 988                 NIL
 989              );
 990     fun    = mkStgLambda(
 991                 args,
 992                 mkStgLet(
 993                    tripleton(e1,e2,e3),
 994                    mkStgApp(
 995                       nameCreateAdjThunk,
 996                       cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
 997                    )
 998                 )
 999              );
1000
1001     v = mkStgVar(fun,NIL);
1002
1003     name(n).defn     = NIL;
1004     name(n).stgVar   = v;
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 /*-------------------------------------------------------------------------*/