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