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