1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
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
11 * $Date: 1998/12/02 13:22:38 $
12 * ------------------------------------------------------------------------*/
19 #include "link.h" /* for nameTrue/False */
20 #include "Assembler.h" /* for AsmRep and primops */
22 /* --------------------------------------------------------------------------
24 * ------------------------------------------------------------------------*/
26 int stgConTag( StgDiscr d )
34 internal("stgConTag");
38 void* stgConInfo( StgDiscr d )
42 return asmMkInfo(cfunOf(d),name(d).arity);
44 return asmMkInfo(0,tupleOf(d));
46 internal("stgConInfo");
50 /* ToDo: identical to stgConTag */
51 int stgDiscrTag( StgDiscr d )
59 internal("stgDiscrTag");
63 /* --------------------------------------------------------------------------
64 * Utility functions for manipulating STG syntax trees.
65 * ------------------------------------------------------------------------*/
67 List makeArgs( Int n )
71 args = cons(mkStgVar(NIL,NIL),args);
76 StgExpr makeStgLambda( List args, StgExpr body )
81 if (whatIs(body) == LAMBDA) {
82 return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
85 return mkStgLambda(args,body);
90 StgExpr makeStgApp( StgVar fun, List args )
95 return mkStgApp(fun,args);
99 StgExpr makeStgLet( List binds, StgExpr body )
104 return mkStgLet(binds,body);
108 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
110 if (cond == nameTrue) {
112 } else if (cond == nameFalse) {
115 return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
116 mkStgCaseAlt(nameFalse,NIL,e2)));
147 StgVar mkStgVar( StgRhs rhs, Cell info )
149 return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
152 /*-------------------------------------------------------------------------*/