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