SchemeByteCodeImpl.mesa
Copyright Ó 1989, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, March 27, 1989 9:45:32 am PST
Last changed by Pavel on March 16, 1989 6:34:49 pm PST
DIRECTORY Rope, Scheme, SchemePrivate;
SchemeByteCodeImpl: CEDAR PROGRAM
IMPORTS Scheme, SchemePrivate
EXPORTS SchemePrivate
~ BEGIN OPEN Scheme, SchemePrivate;
The ByteCode Interpreter
Pop: PROC [a: Activation] RETURNS [Any] ~ {
k: NAT ~ a.bottom ¬ a.bottom - 1;
RETURN [IF k < smallActivationSize THEN a.s[k] ELSE a.sEx[k-smallActivationSize]]
};
Push: PROC [a: Activation, v: Any] ~ {
k: NAT ~ a.bottom;
a.bottom ¬ k + 1;
IF k < smallActivationSize THEN a.s[k] ¬ v ELSE a.sEx[k-smallActivationSize] ¬ v;
};
InterpretByteCodes: PROC [a: Activation] ~ {
pc: INTEGER ¬ a.pc;
e: Environment ~ a.env;
g: PairSeq ~ a.code.globalBindings;
c: SimpleVector ~ a.code.literals;
b: ByteCodes ~ NARROW[c[0]];
GetB: PROC RETURNS [BYTE] ~ INLINE { RETURN [b[(pc¬pc+1)-1]] };
v: CARDINAL;
GetH: PROC RETURNS [INTEGER] ~ INLINE {
v ¬ b[pc]*256+b[pc+1];
pc ¬ pc+2;
RETURN [LOOPHOLE[v]]
};
PushGlobal: PROC [index: INTEGER] ~ INLINE {
pair: Pair ¬ g[index];
IF pair.cdr = undefined THEN
Complain[pair.car, "Undefined variable"]
ELSE
Push[a, pair.cdr];
};
a.bottom ¬ a.bottom + 1; -- Recover returned value on stack after CALL; useless on entry.
DO
op: Opcode ~ VAL[b[pc]];
pc ¬ pc + 1;
SELECT op FROM
enterB => {
size: NAT ~ GetB[];
IF size > smallActivationSize THEN a.sEx ¬ NEW[SimpleVectorRep[size-smallActivationSize]];
a.bottom ¬ 0;
};
enterH => {
size: NAT ~ GetH[];
IF size > smallActivationSize THEN a.sEx ¬ NEW[SimpleVectorRep[size-smallActivationSize]];
a.bottom ¬ 0;
};
call0 => { a.bottom ¬ a.bottom - (a.n ¬ 1); EXIT };
call1 => { a.bottom ¬ a.bottom - (a.n ¬ 2); EXIT };
call2 => { a.bottom ¬ a.bottom - (a.n ¬ 3); EXIT };
call3 => { a.bottom ¬ a.bottom - (a.n ¬ 4); EXIT };
callB => { a.bottom ¬ a.bottom - (a.n ¬ 1+GetB[]); EXIT };
callH => { a.bottom ¬ a.bottom - (a.n ¬ 1+GetH[]); EXIT };
tailCall0 => { a.bottom ¬ a.bottom - (a.n ¬ 1); GOTO Tail };
tailCall1 => { a.bottom ¬ a.bottom - (a.n ¬ 2); GOTO Tail };
tailCall2 => { a.bottom ¬ a.bottom - (a.n ¬ 3); GOTO Tail };
tailCall3 => { a.bottom ¬ a.bottom - (a.n ¬ 4); GOTO Tail };
tailCallB => { a.bottom ¬ a.bottom - (a.n ¬ 1+GetB[]); GOTO Tail };
tailCallH => { a.bottom ¬ a.bottom - (a.n ¬ 1+GetH[]); GOTO Tail };
jumpB => { pc ¬ GetB[] };
jumpH => { pc ¬ GetH[] };
tJumpB => { target: NAT ~ GetB[]; IF True[Pop[a]] THEN pc ¬ target };
tJumpH => { target: NAT ~ GetH[]; IF True[Pop[a]] THEN pc ¬ target };
fJumpB => { target: NAT ~ GetB[]; IF False[Pop[a]] THEN pc ¬ target };
fJumpH => { target: NAT ~ GetH[]; IF False[Pop[a]] THEN pc ¬ target };
pushLiteral1 => { Push[a, c[1]] };
pushLiteral2 => { Push[a, c[2]] };
pushLiteral3 => { Push[a, c[3]] };
pushLiteral4 => { Push[a, c[4]] };
pushLiteralB => { Push[a, c[GetB[]]] };
pushLiteralH => { Push[a, c[GetH[]]] };
pushGlobal0 => { PushGlobal[0] };
pushGlobal1 => { PushGlobal[1] };
pushGlobal2 => { PushGlobal[2] };
pushGlobal3 => { PushGlobal[3] };
pushGlobalB => { PushGlobal[GetB[]] };
pushGlobalH => { PushGlobal[GetH[]] };
pushLocal0B => { Push[a, e[GetB[]]] };
pushLocalBB => {
p: Environment ¬ e;
THROUGH [0..GetB[]) DO p ¬ p.parent ENDLOOP;
Push[a, p[GetB[]]]
};
pushLocalBH => {
p: Environment ¬ e;
THROUGH [0..GetB[]) DO p ¬ p.parent ENDLOOP;
Push[a, p[GetH[]]]
};
pop => { a.bottom ¬ a.bottom - 1 };
popGlobalB => { g[GetB[]].cdr ¬ Pop[a] };
popGlobalH => { g[GetH[]].cdr ¬ Pop[a] };
popLocalBB => {
p: Environment ¬ e;
THROUGH [0..GetB[]) DO p ¬ p.parent ENDLOOP;
p[GetB[]] ¬ Pop[a];
};
popLocalBH => {
p: Environment ¬ e;
THROUGH [0..GetB[]) DO p ¬ p.parent ENDLOOP;
p[GetH[]] ¬ Pop[a];
};
closeB => { Push[a, CloseProcedure[c[GetB[]], e]] };
closeH => { Push[a, CloseProcedure[c[GetH[]], e]] };
return => { a.n ¬ 0; GOTO Tail };
ENDCASE => ERROR;
ENDLOOP;
a.pc ¬ pc;
EXITS Tail => { a.pc ¬ -1 }
};
Creating ByteCoded Procedures
ProcedureFromByteCodeTemplate: PUBLIC PROC [template: ByteCodeTemplate, env: Environment] RETURNS [Procedure] ~ {
TidBitCodeFromBCT: PROC [template: ByteCodeTemplate] RETURNS [TidbitCode] ~ {
globalNames: Any ¬ template.globalNames;
literals: Any ¬ template.literals;
globalBindings: PairSeq ~ NEW[PairSeqRep[ListLength[globalNames]]];
literalsVector: SimpleVector ~ NEW[SimpleVectorRep[ListLength[literals]]];
FOR i: INT IN [0..globalBindings.length) DO
globalBindings[i] ¬ LookupCell[env, Car[globalNames]];
globalNames ¬ Cdr[globalNames];
ENDLOOP;
FOR i: INT IN [0..literalsVector.length) DO
WITH Car[literals] SELECT FROM
bct: ByteCodeTemplate => literalsVector[i] ¬ TidBitCodeFromBCT[bct];
ENDCASE => literalsVector[i] ¬ Car[literals];
literals ¬ Cdr[literals];
ENDLOOP;
RETURN [NEW[TidbitCodeRep ¬ [
name: template.name,
envNames: template.envNames,
dotted: template.dotted,
minArgs: template.minArgs,
maxArgs: template.maxArgs,
proc: InterpretByteCodes,
globalBindings: globalBindings,
literals: literalsVector,
initialPC: 0,
doc: template.doc,
ext: template.ext
]]];
};
RETURN [NEW[TidbitProcedureRep ¬ [code: TidBitCodeFromBCT[template], env: NIL]]];
};
The Assembler
AssemblerOp: TYPE ~ { enter, call, tailCall, jump, tJump, fJump, pushLiteral, pushGlobal, pushLocal, pop, popGlobal, popLocal, close, return, label };
SymbolForAssemberOp: REF ARRAY AssemblerOp OF Symbol ~
NEW[ARRAY AssemblerOp OF Symbol ¬ [
enter: $enter,
call: $call,
tailCall: SymbolFromRope["tail-call"],
jump: $jump,
tJump: $tjump,
fJump: $fjump,
pushLiteral: SymbolFromRope["push-literal"],
pushGlobal: SymbolFromRope["push-global"],
pushLocal: SymbolFromRope["push-local"],
pop: $pop,
popGlobal: SymbolFromRope["pop-global"],
popLocal: SymbolFromRope["pop-local"],
close: $close,
return: $return,
label: $label
]];
AssemblerOpForSymbol: PROC [a: Any] RETURNS [AssemblerOp] ~ {
FOR op: AssemblerOp IN AssemblerOp DO
IF SymbolForAssemberOp[op] = a THEN RETURN [op];
ENDLOOP;
Complain[a, "Illegal Op Code"];
};
JumpOrLabel: TYPE ~ RECORD [
kind: {short, long, label},
label: NAT
];
nullJumpOrLabel: JumpOrLabel ~ [label, 0];
PCSeq: TYPE ~ RECORD[SEQUENCE len: NAT OF NAT];
Assemble: PROC [fn: Any] RETURNS [ByteCodeTemplate] ~ {
code: Any ¬ fn;
Next: PROC RETURNS [a: Any] ~ {
a ¬ Car[code];
code ¬ Cdr[code];
};
name: Any ~ Next[];
minArgs: INT ~ KCheck[Next[]];
maxArgs: INT ~ KCheck[Next[]];
dotted: BOOL ~ True[Next[]];
envNames: SimpleVector ~ NARROW[Next[]];
docString: Rope.ROPE ~ RopeFromString[TheString[Next[]]];
labels: REF PCSeq ~ NEW[PCSeq[KCheck[Next[]]]];
jumpsAndLabels: LIST OF JumpOrLabel ¬ CONS[nullJumpOrLabel, NIL];
jumpsAndLabelsTail: LIST OF JumpOrLabel ¬ jumpsAndLabels;
literals, globals: ProperList ¬ NIL;
sizeInBytes: NAT;
Pass1: PROC RETURNS [NAT] ~ {
Pass 1: Collect all jumps and labels for resolution, all literals and globals for tables.
literalCount: NAT ¬ 1; -- The ByteCodes are literal number zero
globalCount: NAT ¬ 0;
pc: NAT ¬ 0;
FOR tail: Any ¬ code, Cdr[tail] UNTIL tail = NIL DO
inst: Any ~ Car[tail];
instTail: Any ¬ Cdr[inst];
arg: Any ~ IF instTail = NIL THEN NIL ELSE Car[instTail];
SELECT AssemblerOpForSymbol[Car[inst]] FROM
enter =>
IF KCheck[arg] <= LAST[BYTE] THEN
pc ¬ pc + 2
ELSE
pc ¬ pc + 3;
call, tailCall =>
SELECT KCheck[arg] FROM
0, 1, 2, 3 => pc ¬ pc + 1;
<= LAST[BYTE] => pc ¬ pc + 2;
ENDCASE => pc ¬ pc + 3;
jump, tJump, fJump => {
jumpsAndLabelsTail ¬ jumpsAndLabelsTail.rest ¬ CONS[[short, KCheck[arg]], NIL];
pc ¬ pc + 2;
};
pushLiteral => {
literals ¬ Cons[arg, literals];
SELECT literalCount FROM
1, 2, 3, 4 => pc ¬ pc + 1;
<= LAST[BYTE] => pc ¬ pc + 2;
ENDCASE => pc ¬ pc + 3;
literalCount ¬ literalCount + 1;
};
pushGlobal => {
globals ¬ Cons[arg, globals];
SELECT globalCount FROM
0, 1, 2, 3 => pc ¬ pc + 1;
<= LAST[BYTE] => pc ¬ pc + 2;
ENDCASE => pc ¬ pc + 3;
globalCount ¬ globalCount + 1;
};
pushLocal => {
up: NAT ~ KCheck[arg];
over: NAT ~ KCheck[Car[Cdr[instTail]]];
SELECT TRUE FROM
over > LAST[BYTE] => pc ¬ pc + 4; -- pushLocalBH
up = 0  => pc ¬ pc + 2; -- pushLocal0B
ENDCASE  => pc ¬ pc + 3; -- pushLocalBB
};
pop, return =>
pc ¬ pc + 1;
popGlobal => {
globals ¬ Cons[arg, globals];
IF globalCount <= LAST[BYTE] THEN
pc ¬ pc + 2
ELSE
pc ¬ pc + 3;
globalCount ¬ globalCount + 1;
};
popLocal => {
up: NAT ~ KCheck[arg];
over: NAT ~ KCheck[Car[Cdr[instTail]]];
IF over <= LAST[BYTE] THEN
pc ¬ pc + 3  -- popLocalBB
ELSE
pc ¬ pc + 4; -- popLocalBH
};
close => {
literals ¬ Cons[Assemble[arg], literals];
IF literalCount <= LAST[BYTE] THEN
pc ¬ pc + 2
ELSE
pc ¬ pc + 3;
literalCount ¬ literalCount + 1;
};
label => {
n: INT ¬ KCheck[arg];
jumpsAndLabelsTail ¬ jumpsAndLabelsTail.rest ¬ CONS[[label, n], NIL];
labels[n] ¬ pc;
};
ENDCASE;
ENDLOOP;
RETURN [pc]
};
ResolveJumps: PROC ~ {
netIncrease: NAT ¬ 1;
WHILE netIncrease # 0 DO
netIncrease ¬ 0;
FOR list: LIST OF JumpOrLabel ¬ jumpsAndLabels, list.rest UNTIL list = NIL DO
SELECT list.first.kind FROM
short =>
IF labels[list.first.label] > LAST[BYTE] THEN {
list.first.kind ¬ long;
netIncrease ¬ netIncrease + 1;
sizeInBytes ¬ sizeInBytes + 1;
};
long => NULL;
label =>
IF netIncrease > 0 THEN
labels[list.first.label] ¬ labels[list.first.label] + netIncrease;
ENDCASE;
ENDLOOP;
ENDLOOP;
};
Pass2: PROC RETURNS [bc: ByteCodes] ~ {
Pass 2: Generate the actual bytecodes.
literalCount: NAT ¬ 1; -- The ByteCodes are literal number zero
globalCount: NAT ¬ 0;
pc: NAT ¬ 0;
PutB: PROC [b: BYTE] ~ {bc[pc] ¬ b; pc ¬ pc + 1; };
PutH: PROC [n: NAT] ~ {
PutB[n / 256];
PutB[n MOD 256];
};
PutOp: PROC [op: Opcode] ~ { PutB[ORD[op]]; };
Choose: PROC [n: INT, opB, opH: Opcode] ~ {
IF n <= LAST[BYTE] THEN {
PutOp[opB];
PutB[n];
}
ELSE {
PutOp[opH];
PutH[n];
};
};
bc ¬ NEW[ByteCodesRep[sizeInBytes]];
FOR tail: Any ¬ code, Cdr[tail] UNTIL tail = NIL DO
inst: Any ~ Car[tail];
instTail: Any ¬ Cdr[inst];
arg: Any ~ IF instTail = NIL THEN NIL ELSE Car[instTail];
SELECT AssemblerOpForSymbol[Car[inst]] FROM
enter => Choose[KCheck[arg], enterB, enterH];
call => {
n: INT ¬ KCheck[arg];
SELECT n FROM
0 => PutOp[call0];
1 => PutOp[call1];
2 => PutOp[call2];
3 => PutOp[call3];
ENDCASE => Choose[n, callB, callH];
};
tailCall => {
n: INT ¬ KCheck[arg];
SELECT n FROM
0 => PutOp[tailCall0];
1 => PutOp[tailCall1];
2 => PutOp[tailCall2];
3 => PutOp[tailCall3];
ENDCASE => Choose[n, tailCallB, tailCallH];
};
jump => Choose[labels[KCheck[arg]], jumpB, jumpH];
tJump => Choose[labels[KCheck[arg]], tJumpB, tJumpH];
fJump => Choose[labels[KCheck[arg]], fJumpB, fJumpH];
pushLiteral => {
SELECT literalCount FROM
1 => PutOp[pushLiteral1];
2 => PutOp[pushLiteral2];
3 => PutOp[pushLiteral3];
4 => PutOp[pushLiteral4];
ENDCASE => Choose[literalCount, pushLiteralB, pushLiteralH];
literalCount ¬ literalCount + 1;
};
pushGlobal => {
SELECT globalCount FROM
0 => PutOp[pushGlobal0];
1 => PutOp[pushGlobal1];
2 => PutOp[pushGlobal2];
3 => PutOp[pushGlobal3];
ENDCASE => Choose[globalCount, pushGlobalB, pushGlobalH];
globalCount ¬ globalCount + 1;
};
pushLocal => {
up: NAT ~ KCheck[arg];
over: NAT ~ KCheck[Car[Cdr[instTail]]];
SELECT TRUE FROM
over > LAST[BYTE] => {
PutOp[pushLocalBH];
PutB[up];
PutH[over];
};
up = 0 => {
PutOp[pushLocal0B];
PutB[over];
};
ENDCASE => {
PutOp[pushLocalBB];
PutB[up];
PutB[over];
};
};
pop => PutOp[pop];
popGlobal => {
Choose[globalCount, popGlobalB, popGlobalH];
globalCount ¬ globalCount + 1;
};
popLocal => {
up: NAT ~ KCheck[arg];
over: NAT ~ KCheck[Car[Cdr[instTail]]];
IF over <= LAST[BYTE] THEN {
PutOp[popLocalBB];
PutB[up];
PutB[over];
}
ELSE {
PutOp[popLocalBH];
PutB[up];
PutH[over];
};
};
close => {
Choose[literalCount, closeB, closeH];
literalCount ¬ literalCount + 1;
};
return => PutOp[return];
label => NULL;
ENDCASE;
ENDLOOP;
};
sizeInBytes ¬ Pass1[];
jumpsAndLabels ¬ jumpsAndLabels.rest; -- pop off dummy first entry
ResolveJumps[];
RETURN [NEW[ByteCodeTemplateRep ¬ [
name: name,
envNames: envNames,
dotted: dotted,
minArgs: minArgs,
maxArgs: maxArgs,
globalNames: NARROW[Reverse[globals]],
literals: NARROW[Cons[Pass2[], Reverse[literals]]],
doc: docString,
ext: NIL]]];
};
Primitives for ByteCode Compiler
ByteCodePrim: PROC [self: Primitive, a: Any, b: Any, c: Any, rest: ProperList] RETURNS [result: Any] ~ {
SELECT self.data FROM
$assemble => result ¬ Assemble[a];
$bctToProcedure => {
bct: ByteCodeTemplate ~
(WITH a SELECT FROM
bct: ByteCodeTemplate => bct,
ENDCASE => Complain[a, "not a ByteCodeTemplate"]);
env: Environment ~
(WITH b SELECT FROM
env: Environment => env,
ENDCASE => Complain[b, "not an Environment"]);
result ¬ ProcedureFromByteCodeTemplate[bct, env];
};
ENDCASE => ERROR;
};
RegisterPrimitives: PROC [env: Environment] ~ {
DefinePrimitive[name: "%assembly-code->byte-code-template", nArgs: 1, dotted: FALSE, proc: ByteCodePrim, doc: "Assemble the given code, returning a SchemePrivate.ByteCodeTemplate", env: env, data: $assemble];
DefinePrimitive[name: "%byte-code-template->procedure", nArgs: 2, dotted: FALSE, proc: ByteCodePrim, doc: "Convert a SchemePrivate.ByteCodeTemplate into a full procedure", env: env, data: $bctToProcedure];
};
RegisterInit[RegisterPrimitives];
END.
'(lambda (y)
(map (lambda (x)
"Doc-string"
(if (null? x)
0
(car y)))
'(1 2 3)))
("Anonymous 0" 1 1 #f #(y) "(y)" 0
(ENTER 3)
(PUSH-GLOBAL map)
(CLOSE
("Anonymous 0 0" 1 1 #f #(x) "(x) Doc string" 1
(ENTER 2)
(PUSH-GLOBAL null?)
(PUSH-LOCAL 0 0)
(CALL 1)
(FJUMP 0)
(PUSH-LITERAL 0)
(RETURN)
(LABEL 0)
(PUSH-GLOBAL car)
(PUSH-LOCAL 1 0)
(TAIL-CALL 1)))
(PUSH-LITERAL (1 2 3))
(TAIL-CALL 2))
fn ::= (name min max dotted? env-names doc-string num-labels . code*)
code ::= (ENTER n)
| (CALL n)
| (TAIL-CALL n)
| (JUMP n)
| (TJUMP n)
| (FJUMP n)
| (PUSH-LITERAL value)
| (PUSH-GLOBAL symbol)
| (PUSH-LOCAL up over)
| (POP)
| (POP-GLOBAL symbol)
| (POP-LOCAL up over)
| (CLOSE fn)
| (RETURN)
| (LABEL n)