/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
Addrp
putcall(), putcxeq(), putcx1(), realpart();
static long int p2buff
[P2BUFFMAX
];
static long int *p2bufp
= &p2buff
[0];
static long int *p2bufend
= &p2buff
[P2BUFFMAX
];
p2ps("\t.globl\t_%s", s
);
/* put out fake copy of left bracket line, to be redone later */
headoffset
= ftell(textfile
);
p2triple(P2STMT
, (strlen(infname
)+FOUR
-1)/FOUR
, 0);
/* fake jump to start the optimizer */
putgoto( fudgelabel
= newlabel() );
/* jump from top to bottom */
if(s
!=CNULL
&& class!=CLBLOCK
)
int proflab
= newlabel();
p2pi("\t.word\tLWM%d", procno
);
p2pi("\tjmp\tL%d", fudgelabel
= newlabel());
/* It is necessary to precede each procedure with a "left bracket"
* line that tells pass 2 how many register variables and how
* much automatic space is required for the function. This compiler
* does not know how much automatic space is needed until the
* entire procedure has been processed. Therefore, "puthead"
* is called at the begining to record the current location in textfile,
* then to put out a placeholder left bracket line. This procedure
* repositions the file and rewrites that line, then puts the
* file pointer back to the end of the file.
hereoffset
= ftell(textfile
);
if(fseek(textfile
, headoffset
, 0))
if(fseek(textfile
, hereoffset
, 0))
p2triple(P2STMT
, 0, lineno
);
/* put out code for if( ! p) goto l */
if( ( k
= (p
= fixtype(p
))->headblock
.vtype
) != TYLOGICAL
)
err("non-logical expression in IF statement");
p2icon( (long int) l
, P2INT
);
/* put out code for goto l */
p2triple(P2GOTO
, 1, label
);
/* branch to address constant or integer variable */
putcmgo(index
, nlab
, labs
)
struct Labelblock
*labs
[];
int i
, labarray
, skiplabel
;
if(! ISINT(index
->headblock
.vtype
) )
execerr("computed goto index must be integer", CNULL
);
/* use special case instruction */
vaxgoto(index
, nlab
, labs
);
prlabel(asmfile
, labarray
);
prcona(asmfile
, (ftnint
) (skiplabel
= newlabel()) );
for(i
= 0 ; i
< nlab
; ++i
)
prcona(asmfile
, (ftnint
)(labs
[i
]->labelno
) );
prcmgoto(index
, nlab
, skiplabel
, labarray
);
switch(type
= p
->constblock
.vtype
)
p2icon(p
->constblock
.const.ci
, types2
[type
]);
p2triple(P2ICON
, 1, P2INT
|P2PTR
);
(int) p
->constblock
.const.ci
) );
switch(opc
= p
->exprblock
.opcode
)
if( ISCOMPLEX(p
->exprblock
.vtype
) )
if(ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
)
|| ISCOMPLEX(p
->exprblock
.rightp
->headblock
.vtype
) )
if( ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
) ||
ISCOMPLEX(p
->exprblock
.rightp
->headblock
.vtype
) )
if(ISCHAR(p
->exprblock
.leftp
))
if(INT(p
->exprblock
.leftp
->headblock
.vtype
) &&
ISICON(p
->exprblock
.rightp
) &&
( (k
= log2(p
->exprblock
.rightp
->constblock
.const.ci
))>0) )
p
->exprblock
.opcode
= OPLSHIFT
;
frexpr(p
->exprblock
.rightp
);
p
->exprblock
.rightp
= ICON(k
);
if( ISCOMPLEX(p
->exprblock
.vtype
) )
if( ISCOMPLEX(p
->exprblock
.vtype
) )
else if( ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
) )
putx( mkconv(p
->exprblock
.vtype
,
realpart(putcx1(p
->exprblock
.leftp
,
putcomma(ncomma
, p
->exprblock
.vtype
, NO
);
switch(p
->exprblock
.opcode
) /* check for special cases and rewrite */
lt
= lp
->headblock
.vtype
;
while(p
->tag
==TEXPR
&& p
->exprblock
.opcode
==OPCONV
&&
( (ISREAL(pt
)&&ISREAL(lt
)) ||
(INT(pt
)&&(ONEOF(lt
,MSKINT
|MSKADDR
|MSKCHAR
|M(TYSUBR
)))) ))
if(pt
==TYINT
&& lt
==TYLONG
)
if(lt
==TYINT
&& pt
==TYLONG
)
if(pt
==TYDREAL
&& lt
==TYREAL
)
lp
->exprblock
.opcode
==OPCONV
&&
lp
->exprblock
.leftp
->headblock
.vtype
==TYDREAL
)
putx(lp
->exprblock
.leftp
);
if(lt
==TYCHAR
&& lp
->tag
==TEXPR
&&
lp
->exprblock
.opcode
==OPCALL
)
p
->exprblock
.leftp
= (expptr
) putcall(lp
);
lt
= lp
->headblock
.vtype
;
if(p
->tag
==TEXPR
&& p
->exprblock
.opcode
==OPCONV
)
mktemp(lp
->headblock
.vtype
,lp
->headblock
.vleng
);
putx( mkexpr(OPASSIGN
, cpexpr(tp
), lp
) );
/* take advantage of a glitch in the code generator that does not check
the type clash in an assignment or comparison of an integer zero and
a floating left operand, and generates optimal code for the correct
type. (The PCC has no floating-constant node to encode this correctly.)
if(ISREAL(p
->exprblock
.leftp
->headblock
.vtype
) &&
ISREAL(p
->exprblock
.rightp
->headblock
.vtype
) &&
ISCONST(p
->exprblock
.rightp
) &&
p
->exprblock
.rightp
->constblock
.const.cd
[0]==0)
p
->exprblock
.rightp
->constblock
.vtype
= TYINT
;
p
->exprblock
.rightp
->constblock
.const.ci
= 0;
if( (k
= ops2
[p
->exprblock
.opcode
]) <= 0)
badop("putop", p
->exprblock
.opcode
);
putx(p
->exprblock
.leftp
);
putx(p
->exprblock
.rightp
);
p2op(k
, types2
[p
->exprblock
.vtype
]);
frexpr(p
->exprblock
.vleng
);
p
= mkconv(t
, fixtype(p
));
(t
==TYSHORT
? P2SHORT
: (t
==TYLONG
? P2LONG
: P2DREAL
)) );
if(!ISICON(p
->exprblock
.rightp
) ||
(k
= p
->exprblock
.rightp
->constblock
.const.ci
)<2)
fatal("putpower: bad call");
base
= p
->exprblock
.leftp
;
type
= base
->headblock
.vtype
;
t1
= mktemp(type
, PNULL
);
putassign(cpexpr(t1
), cpexpr(base
) );
for( ; (k
&1)==0 && k
>2 ; k
>>=1 )
putx( mkexpr(OPSTAR
, cpexpr(t1
), cpexpr(t1
)) );
t2
= mktemp(type
, PNULL
);
putassign(cpexpr(t2
), cpexpr(t1
));
putx( mkexpr(OPSTAR
, cpexpr(t2
),
mkexpr(OPSTAR
, cpexpr(t1
), cpexpr(t1
)) ));
putcomma(ncomma
, type
, NO
);
LOCAL Addrp
intdouble(p
, ncommap
)
t
= mktemp(TYDREAL
, PNULL
);
badtag("putcxeq", p
->tag
);
lp
= putcx1(p
->exprblock
.leftp
, &ncomma
);
rp
= putcx1(p
->exprblock
.rightp
, &ncomma
);
putassign(realpart(lp
), realpart(rp
));
if( ISCOMPLEX(p
->exprblock
.vtype
) )
putassign(imagpart(lp
), imagpart(rp
));
putcomma(ncomma
, TYREAL
, NO
);
putaddr( putcx1(p
, &ncomma
), NO
);
putcomma(ncomma
, TYINT
, NO
);
LOCAL Addrp
putcx1(p
, ncommap
)
if( ISCOMPLEX(p
->constblock
.vtype
) )
p
= (expptr
) putconst(p
);
resp
= mktemp(tyint
, PNULL
);
putassign( cpexpr(resp
), p
->addrblock
.memoffset
);
p
->addrblock
.memoffset
= (expptr
)resp
;
if( ISCOMPLEX(p
->exprblock
.vtype
) )
resp
= mktemp(TYDREAL
, NO
);
putassign( cpexpr(resp
), p
);
badtag("putcx1", p
->tag
);
opcode
= p
->exprblock
.opcode
;
if(opcode
==OPCALL
|| opcode
==OPCCALL
)
else if(opcode
== OPASSIGN
)
resp
= mktemp(p
->exprblock
.vtype
, PNULL
);
if(lp
= putcx1(p
->exprblock
.leftp
, ncommap
) )
if(rp
= putcx1(p
->exprblock
.rightp
, ncommap
) )
putassign( realpart(resp
), mkexpr(OPNEG
, realpart(lp
), ENULL
) );
putassign( imagpart(resp
), mkexpr(OPNEG
, imagpart(lp
), ENULL
) );
putassign( realpart(resp
),
mkexpr(opcode
, realpart(lp
), realpart(rp
) ));
putassign( imagpart(resp
), imagpart(lp
) );
else if(ltype
< TYCOMPLEX
)
putassign( imagpart(resp
), imagpart(rp
) );
else putassign( imagpart(resp
),
mkexpr(OPNEG
, imagpart(rp
), ENULL
) );
putassign( imagpart(resp
),
mkexpr(opcode
, imagpart(lp
), imagpart(rp
) ));
lp
= intdouble(lp
, ncommap
);
putassign( realpart(resp
),
mkexpr(OPSTAR
, cpexpr(lp
), realpart(rp
) ));
putassign( imagpart(resp
),
mkexpr(OPSTAR
, cpexpr(lp
), imagpart(rp
) ));
else if(rtype
< TYCOMPLEX
)
rp
= intdouble(rp
, ncommap
);
putassign( realpart(resp
),
mkexpr(OPSTAR
, cpexpr(rp
), realpart(lp
) ));
putassign( imagpart(resp
),
mkexpr(OPSTAR
, cpexpr(rp
), imagpart(lp
) ));
putassign( realpart(resp
), mkexpr(OPMINUS
,
mkexpr(OPSTAR
, realpart(lp
), realpart(rp
)),
mkexpr(OPSTAR
, imagpart(lp
), imagpart(rp
)) ));
putassign( imagpart(resp
), mkexpr(OPPLUS
,
mkexpr(OPSTAR
, realpart(lp
), imagpart(rp
)),
mkexpr(OPSTAR
, imagpart(lp
), realpart(rp
)) ));
/* fixexpr has already replaced all divisions
* by a complex by a function call
rp
= intdouble(rp
, ncommap
);
putassign( realpart(resp
),
mkexpr(OPSLASH
, realpart(lp
), cpexpr(rp
)) );
putassign( imagpart(resp
),
mkexpr(OPSLASH
, imagpart(lp
), cpexpr(rp
)) );
putassign( realpart(resp
), realpart(lp
) );
if( ISCOMPLEX(lp
->vtype
) )
q
= (expptr
) realpart(rp
);
q
= mkrealcon(TYDREAL
, 0.0);
putassign( imagpart(resp
), q
);
badtag("putcxcmp", p
->tag
);
opcode
= p
->exprblock
.opcode
;
lp
= putcx1(p
->exprblock
.leftp
, &ncomma
);
rp
= putcx1(p
->exprblock
.rightp
, &ncomma
);
q
= mkexpr( opcode
==OPEQ
? OPAND
: OPOR
,
mkexpr(opcode
, realpart(lp
), realpart(rp
)),
mkexpr(opcode
, imagpart(lp
), imagpart(rp
)) );
putcomma(ncomma
, TYINT
, NO
);
LOCAL Addrp
putch1(p
, ncommap
)
switch(p
->exprblock
.opcode
)
t
= mktemp(TYCHAR
, ICON(lencat(p
)) );
q
= (expptr
) cpexpr(p
->headblock
.vleng
);
/* put the correct length on the block */
if(!ISICON(p
->exprblock
.vleng
)
|| p
->exprblock
.vleng
->constblock
.const.ci
!=1
|| ! INT(p
->exprblock
.leftp
->headblock
.vtype
) )
fatal("putch1: bad character conversion");
t
= mktemp(TYCHAR
, ICON(1) );
putop( mkexpr(OPASSIGN
, cpexpr(t
), p
) );
badop("putch1", p
->exprblock
.opcode
);
badtag("putch1", p
->tag
);
putaddr( putch1(p
, &ncomma
) , NO
);
putcomma(ncomma
, TYCHAR
, YES
);
badtag("putcheq", p
->tag
);
rp
= p
->exprblock
.rightp
;
if( rp
->tag
==TEXPR
&& rp
->exprblock
.opcode
==OPCONCAT
)
else if( ISONE(lp
->headblock
.vleng
) && ISONE(rp
->headblock
.vleng
) )
putaddr( putch1(lp
, &ncomma
) , YES
);
putaddr( putch1(rp
, &ncomma
) , YES
);
putcomma(ncomma
, TYINT
, NO
);
putx( call2(TYINT
, "s_copy", lp
, rp
) );
putcomma(ncomma
, TYINT
, NO
);
frexpr(p
->exprblock
.vleng
);
badtag("putchcmp", p
->tag
);
rp
= p
->exprblock
.rightp
;
if(ISONE(lp
->headblock
.vleng
) && ISONE(rp
->headblock
.vleng
) )
putaddr( putch1(lp
, &ncomma
) , YES
);
putaddr( putch1(rp
, &ncomma
) , YES
);
p2op(ops2
[p
->exprblock
.opcode
], P2CHAR
);
putcomma(ncomma
, TYINT
, NO
);
p
->exprblock
.leftp
= call2(TYINT
,"s_cmp", lp
, rp
);
p
->exprblock
.rightp
= ICON(0);
lp
= mktmpn(n
, TYLENG
, PNULL
);
cp
= mktmpn(n
, TYADDR
, PNULL
);
putct1(rhs
, lp
, cp
, &n
, &ncomma
);
putx( call4(TYSUBR
, "s_cat", lhs
, cp
, lp
, mkconv(TYLONG
, ICON(n
)) ) );
putcomma(ncomma
, TYINT
, NO
);
LOCAL
putct1(q
, lp
, cp
, ip
, ncommap
)
if(q
->tag
==TEXPR
&& q
->exprblock
.opcode
==OPCONCAT
)
putct1(q
->exprblock
.leftp
, lp
, cp
, ip
, ncommap
);
putct1(q
->exprblock
.rightp
, lp
, cp
, ip
, ncommap
);
frexpr(q
->exprblock
.vleng
);
lp1
= (Addrp
) cpexpr(lp
);
lp1
->memoffset
= mkexpr(OPPLUS
,lp1
->memoffset
, ICON(i
*SZLENG
));
cp1
= (Addrp
) cpexpr(cp
);
cp1
->memoffset
= mkexpr(OPPLUS
, cp1
->memoffset
, ICON(i
*SZADDR
));
putassign( lp1
, cpexpr(q
->headblock
.vleng
) );
putassign( cp1
, addrof(putch1(q
,ncommap
)) );
ftnint offset
, simoffset();
if( p
->tag
==TERROR
|| (p
->memoffset
!=NULL
&& ISERROR(p
->memoffset
)) )
funct
= (p
->vclass
==CLPROC
? P2FUNCT
<<2 : 0);
offp
= (p
->memoffset
? (expptr
) cpexpr(p
->memoffset
) : (expptr
)NULL
);
offp
= mkexpr(OPSTAR
, ICON(FUDGEOFFSET
), offp
);
offset
= simoffset( &offp
);
offp
= mkconv(TYINT
, offp
);
offp
= mkconv(TYINT
, offp
);
p2oreg(offset
, AUTOREG
, type2
);
if(!indir
&& !offp
&& !offset
)
p2reg(AUTOREG
, type2
| P2PTR
);
p2reg(AUTOREG
, type2
| P2PTR
);
p2op(P2PLUS
, type2
| P2PTR
);
p2op(P2PLUS
, type2
| P2PTR
);
(ftnint
) (FUDGEOFFSET
*p
->memno
),
ARGREG
, type2
| P2PTR
| funct
);
p2op(P2PLUS
, type2
| P2PTR
);
p2op(P2PLUS
, type2
| P2PTR
);
(ftnint
) (FUDGEOFFSET
*p
->memno
),
p2reg(ARGREG
, type2
| P2PTR
);
(ftnint
) (FUDGEOFFSET
*p
->memno
), P2INT
);
p2op(P2PLUS
, type2
| P2PTR
);
putmem(p
, P2ICON
, offset
);
p2op(P2PLUS
, type2
| P2PTR
);
putmem(p
, (indir
? P2NAME
: P2ICON
), offset
);
fatal("attempt to take address of a register");
/* for possible future use -- register based arrays
p2oreg(offset, p->memno, type2);
p2reg(p->memno, type2 | P2PTR);
badstg("putaddr", p
->vstg
);
LOCAL
putmem(p
, class, offset
)
funct
= (p
->headblock
.vclass
==CLPROC
? P2FUNCT
<<2 : 0);
type2
= types2
[p
->headblock
.vtype
];
if(p
->headblock
.vclass
== CLPROC
)
name
= memname(p
->addrblock
.vstg
, p
->addrblock
.memno
);
p2triple(P2ICON
, name
[0]!='\0', type2
|P2PTR
);
p2triple(P2NAME
, offset
!=0, type2
);
chainp arglist
, charsp
, cp
;
int type
, type2
, ctype
, qtype
, indir
;
type2
= types2
[type
= p
->vtype
];
indir
= (p
->opcode
== OPCCALL
);
arglist
= p
->rightp
->listblock
.listp
;
free( (charptr
) (p
->rightp
) );
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
q
= (expptr
) (cp
->datap
);
q
= (expptr
) putconst(q
);
if( ISCHAR(q
) && q
->headblock
.vclass
!=CLPROC
)
mkchain(cpexpr(q
->headblock
.vleng
),
fval
= mktemp(TYCHAR
, p
->vleng
);
err("adjustable character function");
else if( ISCOMPLEX(type
) )
fval
= mktemp(type
, PNULL
);
ctype
= (fval
? P2INT
: type2
);
putaddr( cpexpr(fval
), NO
);
putx( mkconv(TYLENG
,p
->vleng
) );
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
q
= (expptr
) (cp
->datap
);
if(q
->tag
==TADDR
&& (indir
|| q
->addrblock
.vstg
!=STGREG
) )
putaddr(q
, indir
&& q
->addrblock
.vtype
!=TYCHAR
);
else if( ISCOMPLEX(q
->headblock
.vtype
) )
t
= mktemp(qtype
= q
->headblock
.vtype
,
putassign( cpexpr(t
), q
);
for(cp
= charsp
; cp
; cp
= cp
->nextp
)
putx( mkconv(TYLENG
,cp
->datap
) );
p2op(n
>0 ? P2CALL
: P2CALL0
, ctype
);
badtag("putmnmx", p
->tag
);
type
= p
->exprblock
.vtype
;
op
= (p
->exprblock
.opcode
==OPMIN
? OPLT
: OPGT
);
p0
= p
->exprblock
.leftp
->listblock
.listp
;
free( (charptr
) (p
->exprblock
.leftp
) );
sp
= mktemp(type
, PNULL
);
tp
= mktemp(type
, PNULL
);
qp
= mkexpr(OPCOLON
, cpexpr(tp
), cpexpr(sp
));
qp
= mkexpr(OPQUEST
, mkexpr(op
, cpexpr(tp
),cpexpr(sp
)), qp
);
putassign( cpexpr(sp
), p0
->datap
);
for(p1
= p0
->nextp
; p1
; p1
= p1
->nextp
)
putassign( cpexpr(tp
), p1
->datap
);
putassign( cpexpr(sp
), cpexpr(qp
) );
putcomma(ncomma
, type
, NO
);
LOCAL
putcomma(n
, type
, indir
)
register expptr p
, lp
, rp
;
if( ! ISINT(p
->headblock
.vtype
) )
if(p
->tag
==TEXPR
&& p
->exprblock
.opcode
==OPSTAR
)
rp
= p
->exprblock
.rightp
;
if(ISICON(rp
) && lp
->tag
==TEXPR
&&
lp
->exprblock
.opcode
==OPPLUS
&& ISICON(lp
->exprblock
.rightp
))
p
->exprblock
.opcode
= OPPLUS
;
lp
->exprblock
.opcode
= OPSTAR
;
prod
= rp
->constblock
.const.ci
*
lp
->exprblock
.rightp
->constblock
.const.ci
;
lp
->exprblock
.rightp
->constblock
.const.ci
= rp
->constblock
.const.ci
;
rp
->constblock
.const.ci
= prod
;
if(p
->tag
==TEXPR
&& p
->exprblock
.opcode
==OPPLUS
&&
ISICON(p
->exprblock
.rightp
))
rp
= p
->exprblock
.rightp
;
offset
+= rp
->constblock
.const.ci
;
offset
+= p
->constblock
.const.ci
;
p2triple(P2ICON
, 0, type
);
p2oreg(offset
, reg
, type
)
p2triple(P2OREG
, reg
, type
);
p2triple(P2REG
, reg
, type
);
p2triple(P2PASS
, (strlen(s
) + FOUR
-1)/FOUR
, 0);
union { long int word
; char str
[FOUR
]; } u
;
word
|= ( (long int) type
) <<16;
/* arbitrary length names, terminated by a null,
# define WL sizeof(long int)
union { long int word
; char str
[WL
]; } w
;
/* standard intermediate, names are 8 characters long */
union { long int word
[2]; char str
[8]; } u
;
u
.word
[0] = u
.word
[1] = 0;
for(i
= 0 ; i
<8 && *s
; ++i
)
write(fileno(textfile
), p2buff
, (p2bufp
-p2buff
)*sizeof(long int));