ghc/interpreter/stg.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * STG syntax
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: stg.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:38 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "errors.h"
  18 #include "stg.h"
  19 #include "link.h"      /* for nameTrue/False     */
  20 #include "Assembler.h" /* for AsmRep and primops */
  21
  22 /* --------------------------------------------------------------------------
  23  * Utility functions
  24  * ------------------------------------------------------------------------*/
  25
  26 int stgConTag( StgDiscr d )
  27 {
  28     switch (whatIs(d)) {
  29     case NAME:
  30             return cfunOf(d);
  31     case TUPLE:
  32             return 0;
  33     default:
  34             internal("stgConTag");
  35     }
  36 }
  37
  38 void* stgConInfo( StgDiscr d )
  39 {
  40     switch (whatIs(d)) {
  41     case NAME:
  42             return asmMkInfo(cfunOf(d),name(d).arity);
  43     case TUPLE:
  44             return asmMkInfo(0,tupleOf(d));
  45     default:
  46             internal("stgConInfo");
  47     }
  48 }
  49
  50 /* ToDo: identical to stgConTag */
  51 int stgDiscrTag( StgDiscr d )
  52 {
  53     switch (whatIs(d)) {
  54     case NAME:
  55             return cfunOf(d);
  56     case TUPLE:
  57             return 0;
  58     default:
  59             internal("stgDiscrTag");
  60     }
  61 }
  62
  63 /* --------------------------------------------------------------------------
  64  * Utility functions for manipulating STG syntax trees.
  65  * ------------------------------------------------------------------------*/
  66
  67 List makeArgs( Int n )
  68 {
  69     List args = NIL;
  70     for(; n>0; --n) {
  71         args = cons(mkStgVar(NIL,NIL),args);
  72     }
  73     return args;
  74 }
  75
  76 StgExpr makeStgLambda( List args, StgExpr body )
  77 {
  78     if (isNull(args)) {
  79         return body;
  80     } else {
  81         if (whatIs(body) == LAMBDA) {
  82             return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
  83                                stgLambdaBody(body));
  84         } else {
  85             return mkStgLambda(args,body);
  86         }
  87     }
  88 }
  89
  90 StgExpr makeStgApp( StgVar fun, List args )
  91 {
  92     if (isNull(args)) {
  93         return fun;
  94     } else {
  95         return mkStgApp(fun,args);
  96     }
  97 }
  98
  99 StgExpr makeStgLet( List binds, StgExpr body )
 100 {
 101     if (isNull(binds)) {
 102         return body;
 103     } else {
 104         return mkStgLet(binds,body);
 105     }
 106 }
 107
 108 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
 109 {
 110     if (cond == nameTrue) {
 111         return e1;
 112     } else if (cond == nameFalse) {
 113         return e2;
 114     } else {
 115         return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
 116                                         mkStgCaseAlt(nameFalse,NIL,e2)));
 117     }
 118 }
 119
 120 Bool isStgVar(e)
 121 StgRhs e; {
 122     switch (whatIs(e)) {
 123     case STGVAR:
 124             return TRUE;
 125     default:
 126             return FALSE;
 127     }
 128 }
 129
 130 Bool isAtomic(e)
 131 StgRhs e; {
 132     switch (whatIs(e)) {
 133     case STGVAR:
 134     case NAME:
 135     case CHARCELL:
 136     case INTCELL:
 137     case BIGCELL:
 138     case FLOATCELL:
 139     case STRCELL:
 140     case PTRCELL:
 141             return TRUE;
 142     default:
 143             return FALSE;
 144     }
 145 }
 146
 147 StgVar mkStgVar( StgRhs rhs, Cell info )
 148 {
 149     return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
 150 }
 151
 152 /*-------------------------------------------------------------------------*/