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