!! 28-JAN-81
! **************************************************************
! * *
! * PERKIN-ELMER 32-BIT SERIES IMP COMPILER *
! * INTERMEDIATE CODE ASSEMBLER *
! * *
! * (GENERAL SERVICE VERSION) *
! * *
! * C.H. WHITFIELD *
! * 19, REDFORD TERRACE *
! * COLINTON, *
! * EDINBURGH EH13-0BT *
! * *
! * COPYRIGHT (c) MAY 1ST. 1980 *
! * ALL RIGHTS RESERVED *
! * *
! **************************************************************
! Pass 3 for 7/32 Imp
! ===========
! N.B. All loader-visible addresses generated by pass2 are in units
! of halfwords.
! ===========
! ****Compatibility header: to disappear with old-format EXE files
constinteger h8 = 8
!
begin
!!%include "Sysinc:Com.inc"
{Include file for compiler communication}
recordformat impcomfm(integer statements, flags, code, gla, diags, perm,
string(31) file,
string(63) Option)
externalrecord(impcomfm)spec IMPCOM
!%endoffile
constinteger direct=1, object=2
constinteger report=0
! N.B. <0 for diagnostic tracing, >0 for extra details of dumped code
constinteger diagnostic = 0
constinteger register template = x'7DEF'; ! wsp, code, gla, link
constinteger max tag=2050
constinteger max ref=2900
constinteger max proc=255
constinteger bmax = 8; ! no. of DA buffers available to phase 2
constinteger safe pc rel = 6500; ! 'SAFE' limit in stretch routines q.v.
! Parameters related to diagnostic table generation
constinteger indirect = x'4000'
constinteger line diag limit = 31
constinteger proc header=1, diag entry=0, linkage name=-1; ! 'descriptions'
constinteger none = 0, partial = 1, full = 2
owninteger diags = full, hide = 0
constinteger main prog = x'4000'; ! main program marker in event chain
conststring(3) main ep = "%GO"; ! must match pass 2
conststring(6) trace ep = "$TRACE"; ! likewise
constinteger init lit = 4; ! halfwords: must not exceed pass 2 value
!********
constshortinteger max prim = 52
constshortintegerarray prim(1:1018) = c
x'026F',x'0215',x'0224',x'0035',x'0064',x'0087',x'00D7',x'015A',x'00C1',
x'0232',x'029A',x'0160',x'02B3',x'02C7',x'02E7',x'030A',x'01C5',x'01F5',
x'01AB',x'0335',x'02AA',x'0294',x'028E',x'0278',x'0288',x'0315',x'0188',
x'0194',x'02A2',x'0051',x'0251',x'0265',x'0244',x'019E',x'03AF',x'03CD',
x'03DC',x'03EC',x'0000',x'0000',x'0000',x'0000',x'0000',x'0000',x'0000',
x'0000',x'0000',x'0000',x'039C',x'03A3',x'0338',x'033F',x'001B',x'480F',
x'0000',x'2133',x'3402',x'9400',x'9300',x'D331',x'0000',x'C530',x'0080',
x'2138',x'D431',x'0001',x'2135',x'2408',x'2411',x'8883',x'0034',x'0503',
x'2385',x'2401',x'2417',x'8883',x'0034',x'26F2',x'8888',x'001E',x'0012',
x'0512',x'033F',x'D331',x'0000',x'9433',x'3443',x'F830',x'FF00',x'0001',
x'D301',x'4400',x'0000',x'D202',x'4400',x'0000',x'0A43',x'2087',x'030F',
x'0022',x'480F',x'0000',x'2133',x'3402',x'9400',x'9300',x'D331',x'0000',
x'C530',x'0080',x'2138',x'D431',x'0001',x'2135',x'2408',x'2411',x'8883',
x'0034',x'2440',x'0503',x'2383',x'0830',x'2304',x'D301',x'4400',x'0000',
x'D202',x'4400',x'0000',x'2641',x'2731',x'2218',x'430F',x'0002',x'0039',
x'480F',x'0000',x'2133',x'3402',x'9400',x'9300',x'D331',x'0000',x'C530',
x'0080',x'2138',x'D431',x'0001',x'2135',x'2408',x'2411',x'8883',x'0034',
x'D342',x'0000',x'C540',x'0080',x'2134',x'D442',x'0001',x'223B',x'0A43',
x'C540',x'0100',x'2185',x'2401',x'2413',x'8883',x'0034',x'0B04',x'2315',
x'2401',x'2417',x'8883',x'0034',x'D242',x'0000',x'0B43',x'0A42',x'2450',
x'2308',x'D301',x'4500',x'0001',x'D204',x'4500',x'0001',x'2651',x'2731',
x'2218',x'430F',x'0002',x'0015',x'2441',x'D331',x'0000',x'D302',x'0000',
x'0B30',x'231B',x'0A03',x'2309',x'D351',x'4400',x'0000',x'D452',x'4400',
x'0000',x'023F',x'2641',x'2701',x'2219',x'0833',x'030F',x'0082',x'735F',
x'0000',x'9465',x'1058',x'2133',x'3452',x'9455',x'9355',x'1068',x'2133',
x'3464',x'9466',x'9366',x'D0B7',x'0000',x'D3B3',x'0000',x'C5B0',x'0080',
x'2134',x'D4B3',x'0001',x'2339',x'D301',x'0000',x'C500',x'0080',x'2138',
x'D401',x'0001',x'2135',x'2408',x'2411',x'8883',x'0034',x'0BB0',x'4210',
x'80A8',x'24C0',x'0800',x'4330',x'8038',x'D301',x'0001',x'D403',x'4C00',
x'0001',x'2339',x'26C1',x'05BC',x'2286',x'4300',x'808A',x'D301',x'0001',
x'2207',x'08E3',x'0AEC',x'D3D1',x'0000',x'27D1',x'D30E',x'4D00',x'0001',
x'D401',x'4D00',x'0001',x'203E',x'27D1',x'2028',x'0822',x'2334',x'055C',
x'4280',x'8062',x'08DC',x'0844',x'233A',x'D301',x'0000',x'0AC0',x'D3E3',
x'0000',x'0BEC',x'056E',x'4280',x'804A',x'0822',x'233C',x'D2D2',x'0000',
x'2307',x'D303',x'4D00',x'0001',x'D202',x'4D00',x'0001',x'27D1',x'2217',
x'0844',x'4330',x'801C',x'D2E4',x'0000',x'0AC3',x'24D0',x'2308',x'D30C',
x'4D00',x'0001',x'D204',x'4D00',x'0001',x'26D1',x'27E1',x'2218',x'2501',
x'D1B7',x'0000',x'430F',x'0002',x'2400',x'2205',x'D1B7',x'0000',x'2401',
x'2417',x'8883',x'0034',x'0005',x'023F',x'2407',x'2410',x'8883',x'0034',
x'0027',x'D301',x'0000',x'C500',x'0080',x'2138',x'D401',x'0001',x'2135',
x'2408',x'2411',x'8883',x'0034',x'0822',x'2326',x'0503',x'2184',x'CB32',
x'FFFF',x'2316',x'0843',x'2405',x'2414',x'8883',x'0034',x'0A21',x'C817',
x'0000',x'D231',x'0000',x'2307',x'D302',x'4300',x'0000',x'D201',x'4300',
x'0001',x'2731',x'2217',x'030F',x'000B',x'1132',x'2307',x'5801',x'4300',
x'0000',x'5002',x'4300',x'0000',x'2734',x'2217',x'030F',x'0009',x'1132',
x'2400',x'2304',x'5002',x'4300',x'0000',x'2734',x'2214',x'030F',x'000C',
x'0B44',x'D301',x'4400',x'0000',x'D402',x'4400',x'0000',x'023F',x'2641',
x'0543',x'2039',x'030F',x'0019',x'0831',x'4932',x'0002',x'212C',x'4B32',
x'0000',x'2119',x'0A33',x'7333',x'4200',x'0004',x'2339',x'0A33',x'0A3E',
x'0303',x'0821',x'2406',x'2413',x'8883',x'0034',x'0821',x'2408',x'2412',
x'8883',x'0034',x'002F',x'D097',x'0000',x'2431',x'2410',x'489F',x'0000',
x'08B4',x'48AF',x'0002',x'58CB',x'0008',x'5BCB',x'0004',x'26C1',x'4210',
x'8030',x'50CB',x'0000',x'1C0C',x'5B1B',x'0004',x'1C2C',x'26BC',x'2791',
x'203F',x'50AB',x'0000',x'1C0A',x'1C2A',x'2633',x'C430',x'FFFC',x'48CF',
x'0000',x'50C4',x'0000',x'D197',x'0000',x'430F',x'0004',x'084B',x'D197',
x'0000',x'2405',x'2413',x'8883',x'0034',x'001F',x'0807',x'0A03',x'590D',
x'0000',x'2325',x'2402',x'2411',x'8883',x'0034',x'0A71',x'5072',x'0000',
x'5042',x'0004',x'2628',x'0870',x'580E',x'000C',x'F500',x'8080',x'8080',
x'023F',x'2450',x'0B53',x'033F',x'5007',x'4500',x'0000',x'2654',x'2034',
x'030F',x'000E',x'0822',x'2315',x'2405',x'2412',x'8883',x'0034',x'2401',
x'2411',x'2302',x'1C03',x'2721',x'2212',x'8888',x'0015',x'000D',x'2401',
x'2F00',x'0801',x'2316',x'2D02',x'2820',x'2400',x'CB01',x'0001',x'033F',
x'2C02',x'2701',x'2203',x'8010',x'2802',x'2114',x'6A00',x'8010',x'2305',
x'6B00',x'800A',x'6A20',x'800A',x'2800',x'2B20',x'030F',x'4600',x'0000',
x'4110',x'0000',x'0000',x'800C',x'2822',x'2114',x'6A20',x'800C',x'2303',
x'6B20',x'8006',x'2E12',x'030F',x'0000',x'4080',x'0000',x'0013',x'480F',
x'0000',x'2133',x'3401',x'9400',x'9300',x'0822',x'2328',x'0502',x'2186',
x'E611',x'4200',x'0000',x'430F',x'0002',x'2406',x'2415',x'8883',x'0034',
x'0009',x'581D',x'0000',x'CB17',x'0200',x'031F',x'2402',x'2411',x'8883',
x'0034',x'0008',x'023F',x'2408',x'2411',x'8883',x'0034',x'0000',x'8080',
x'8080',x'000F',x'0822',x'233A',x'0B10',x'0801',x'EE00',x'001F',x'1D02',
x'0811',x'2113',x'0800',x'033F',x'2405',x'2411',x'8883',x'0034',x'0005',
x'033F',x'2404',x'2412',x'8883',x'0034',x'0005',x'033F',x'2401',x'2415',
x'8883',x'0034',x'0005',x'034F',x'2401',x'2415',x'8883',x'0034',x'0007',
x'D401',x'0000',x'038F',x'2401',x'2417',x'8883',x'0034',x'0007',x'C320',
x'FFE0',x'033F',x'2405',x'2416',x'8883',x'0034',x'0008',x'0800',x'033F',
x'2601',x'033F',x'2401',x'2411',x'8883',x'0034',x'0013',x'5823',x'0004',
x'5912',x'0004',x'2119',x'5912',x'0008',x'2126',x'5C02',x'000C',x'5A13',
x'0000',x'030F',x'0842',x'0821',x'2406',x'2412',x'8883',x'0034',x'001F',
x'5843',x'0004',x'5914',x'0004',x'4210',x'8028',x'5914',x'0008',x'4220',
x'8020',x'5C04',x'000C',x'5924',x'0010',x'211A',x'5924',x'0014',x'2127',
x'0A12',x'5C04',x'0018',x'5A13',x'0000',x'030F',x'0812',x'264C',x'0821',
x'2406',x'2412',x'8883',x'0034',x'0022',x'5853',x'0004',x'5845',x'0000',
x'2741',x'1142',x'0A42',x'0801',x'2410',x'2744',x'5905',x'0004',x'4210',
x'801C',x'5905',x'0008',x'212C',x'0A10',x'5C05',x'000C',x'265C',x'5804',
x'0000',x'0542',x'228F',x'5A13',x'0000',x'030F',x'0845',x'0820',x'2406',
x'2412',x'8883',x'0034',x'000A',x'5843',x'0004',x'5C04',x'000C',x'0A12',
x'5C04',x'0018',x'5A13',x'0000',x'030F',x'001F',x'0847',x'484F',x'0000',
x'732F',x'0002',x'1122',x'0B42',x'0A27',x'583D',x'0000',x'C532',x'0200',
x'2385',x'2402',x'2411',x'8883',x'0034',x'26F4',x'0872',x'F830',x'8080',
x'8080',x'553E',x'000C',x'023F',x'5037',x'4400',x'0000',x'2644',x'2224',
x'030F',x'0002',x'8883',x'0034',x'0006',x'D007',x'002C',x'0867',x'CA70',
x'006C',x'8102',x'005C',x'D007',x'002C',x'584D',x'0008',x'2337',x'5004',
x'0000',x'5014',x'0004',x'5024',x'0008',x'C8A7',x'0040',x'0810',x'2441',
x'ED41',x'0000',x'0813',x'4120',x'805C',x'0855',x'2315',x'083F',x'0813',
x'4120',x'8050',x'4826',x'0002',x'9352',x'1152',x'585A',x'45FF',x'FFEC',
x'0822',x'4210',x'8022',x'7316',x'0008',x'0A11',x'0A1E',x'0931',x'232C',
x'4816',x'0004',x'0414',x'2338',x'D17A',x'0008',x'7316',x'0006',x'0A11',
x'0A1E',x'0301',x'C320',x'4000',x'2138',x'5835',x'0028',x'58E5',x'0024',
x'08A5',x'4300',x'FFB0',x'D107',x'002C',x'8101',x'736E',x'40FF',x'FFFE',
x'0A66',x'0B1E',x'7306',x'4E00',x'0000',x'0A00',x'0856',x'0B50',x'0916',
x'2123',x'0915',x'2128',x'0865',x'221B',x'D107',x'002C',x'2400',x'241F',
x'8101',x'0855',x'0212',x'0A6E',x'0302',x'0006',x'583D',x'0004',x'08C8',
x'0183',x'088C',x'030F',x'000B',x'486F',x'0000',x'26F2',x'085F',x'D057',
x'0000',x'D1DD',x'8887',x'082F',x'08F5',x'0302',x'001D',x'2400',x'C830',
x'001C',x'5841',x'4300',x'0000',x'5852',x'4300',x'0000',x'0865',x'0464',
x'0964',x'2333',x'C600',x'0001',x'0965',x'2333',x'C600',x'0002',x'2734',
x'4310',x'FFDA',x'2460',x'450F',x'0000',x'2132',x'2461',x'430F',x'0002',
x'000E',x'C830',x'001C',x'5801',x'4300',x'0000',x'5602',x'4300',x'0000',
x'5001',x'4300',x'0000',x'2734',x'221A',x'030F',x'000F',x'C830',x'001C',
x'2501',x'5702',x'4300',x'0000',x'5401',x'4300',x'0000',x'5001',x'4300',
x'0000',x'2734',x'221B',x'030F',x'000E',x'C830',x'001C',x'5801',x'4300',
x'0000',x'5402',x'4300',x'0000',x'5001',x'4300',x'0000',x'2734',x'221A',
x'030F'
!********
! ==== control codes ====
constinteger tag defn = 1
constinteger r ref = 2
constinteger p ref = 3
constinteger sw ref = 4
constinteger j ref = 5
constinteger c ref = 6
constinteger code item = 7
constinteger gla item = 8
constinteger line diag = 9
constinteger line reset = 10
constinteger var diag = 11
constinteger code area = 12
constinteger lit area = 13
constinteger lit org = 14
constinteger frame patch = 15
constinteger proc head = 16
constinteger proc end = 17
constinteger prog end = 18
constinteger code rel = 19
constinteger gla rel = 20
constinteger extern = 21
! external reference sub-types
constinteger data spec = 4, data defn = 5
constinteger ep spec = 6, ep defn = 7
! ======== constants associated with code generation ========
constinteger align=3; ! single word alignment (literal area)
constinteger emark = x'8880', tmark = x'8887'
constinteger backwards = X'0100'; ! short jump modifier
constinteger code base = 14; ! code base register
constinteger BZ = X'433E', BZS = X'2330'
constinteger BNZ = X'423E', BNZS = X'2130'
constinteger BM = X'421E', BMS = X'2110'
constinteger BP = X'422E', BPS = X'2120'
constinteger BNP = X'432E', BNPS = X'2320'
constinteger BNM = X'431E', BNMS = X'2310'
constinteger JMP = X'430E', JMPS = X'2300'
constinteger BAL = X'410E'
constshortintegerarray short jump(0:12) =
BZS, BNZS, BMS, BPS, BNPS, BNMS,
BNZS, BZS, BPS, BMS, BNMS, BNPS, JMPS
constshortintegerarray long jump(0:12) =
BZ, BNZ, BM, BP, BNP, BNM,
BNZ, BZ, BP, BM, BNM, BNP, JMP
! == flag bits used in 'REF' table ==
constinteger short=1
constinteger long=2
constinteger pc rel=4
constinteger very=8
constinteger invert=16
constinteger remove=32
constinteger rcall=64
constinteger safe=128
constinteger conditional=256
! == values used in code generation phase ( reftype(k)=0 -> 'REMOVE' ) ==
constinteger sf=1
constinteger rx1=2
constinteger rx2=3
constinteger rx3=4
constinteger sign bit = x'80000000'
constinteger halfword sign = x'FFFF8000'
! ** Purely for accumulating jump instruction statistics
owninteger sfjump=0, rx1jump=0, rx2jump=0, rx13jump=0
! ** For accumulating counts in various bits of program
owninteger localtot=0,localnonsafe=0, globaltot=0,globalnonsafe=0
owninteger buff miss1=0, buff miss2=0, buff miss3=0
! ** for recording timings
integer t0,t1,t2; ! phase 1, phase 2 timing
integer t10, t11, t12; ! local, global stretch timing (inside phase 1)
recordformat reffm(shortinteger tag, link, flags, ca)
recordformat deffm(record(deffm)name link, shortinteger proc,ca)
recordformat procfm(record(procfm)name link,
record(reffm)name ref list,
record(deffm)name def list,
shortinteger base, ca,
static frame, event mask,
display reg, event start,
event finish, ld base,
ld size, vd base,
vd size, Me)
record(procfm)array proc(1:max proc)
record(deffm)array tagdef(1:max tag)
byteintegerarray reftype(1:max ref)
owninteger refs = 0
constrecord(*)name null == (0)
record(procfm)name proc1, last proc; ! ** N.B. proc1 ultimately is prim **
shortintegerarray prim entry(1:max prim)
integer header size, gla size, code size, literal size
integer var diags, line diags
owninteger defns = 0, specs = 0, relocations = 0
integer current line, line incr, ca incr
integer j,k,l
tagdef(j) = 0 for j = 1,1,max tag
prim entry(j) = -1 for j = 1,1,max prim
proc1 == proc(1); proc1 = 0
last proc == proc1
routine phex(shortinteger n)
integer j,k
for j = 12,-4,0 cycle
k = (n>>j)&15
if k < 10 then k = k+'0' else k = k-10+'A'
print symbol(k)
repeat
end
routine error(integer n,p)
select output(report)
print string("*ERROR"); write(n,1)
print symbol(':'); write(p,4)
newline
signal 15,15
end
routine get(integername n)
integer j,k
read symbol(j); read symbol(K)
n = j<<8 ! k
end
routine phase one; ! Input directives and expand jumps
record(reffm)array ref(1:max ref)
record(procfm)name pp, qq
integer procs; procs = 0
integer ca total; ca total = 0
integer extra, n
integer j
routine input directives
owninteger depth = 0
owninteger code = 0, n = 0, ca = 0
record(reffm)name r
record(deffm)name d, dd
record(procfm)name p
integer last ref, this proc, last line
switch dir(1:extern)
depth = depth+1
procs = procs+1
this proc = procs; p == proc(procs); p = 0
P_Me = This proc
p_ld size = diags; ! FRIG: 0 = none, 1 = partial, 2 full
! 0 + ( ( line org + ( link )? )?
p_vd size = 0
if diags > none start; ! p_vd size set = zero above
p_vd size = 4; ! procedure identifier
p_vd size = 5 if diags = full; ! link required as well
finish
last line = current line; ! ???????
last ref = 0; r == null
cycle
read symbol(code)
-> dir(code) if 0 < code <= extern
!!dir(*):
error(0,code)
dir(proc head): ! <proc index>
read symbol(n); error(1,n) unless n = procs
input directives
continue
dir(proc end): ! <code size> <no. var diags> <static frame size>
! <local display register> <event mask> <event start> <event finish>
get(ca)
get(n)
p_vd size = p_vd size + n if diags = full; ! header+local idents
get(n); p_static frame <- n
p_display reg = next symbol; skip symbol; ! avoid any limited 'read symbol'
get(n); p_event mask <- n
get(n); p_event start = n; ! tag no
get(n); p_event finish = n; ! tag no
depth = depth-1; return if depth = 0
p_ca = ca+2; ! size + basic event header
p_ca = p_ca+3 if p_event mask # 0; ! full form required
ca total = ca total + ca
! *** reverse reference list - should grow it forwards ***
if not r == null start
n = last ref; last ref = 0
while n # 0 cycle
r == ref(n)
k = r_link; r_link = last ref
last ref = n
n = k
repeat
finish
p_ref list == r
last proc_link == p; last proc == p
return
dir(tag defn): ! <tag no> <ca> *N.B. switch defns. have x'8000' bit set*
get(j); get(ca)
n = j&x'7FFF'; ! mask out 'switch' bit
error(3,n) unless 0 < n <= max tag
d == tag def(n)
if not d_link == null start; ! already defined
error(4,n) if j&x'8000' = 0; ! not a switch tag so it's an error
! remove existing entry so it can be redefined
if not p_def list == d start
dd == p_def list
dd == dd_link while not dd_link == d
dd_link == d_link
else
p_def list == d_link
finish
finish
d_proc = this proc; d_ca = ca
d_link == p_def list
p_def list == d
continue
dir(r ref): ! <n> <ca>
code = r call + long; -> ref ref
dir(j ref):
code = short; -> ref ref
dir(c ref):
code = short + conditional
ref ref:
get(n); get(ca)
error(5,n) unless 0 < n <= max tag
error(6,n) if refs = max ref
refs = refs+1
r == ref(refs)
r_link = last ref; last ref = refs
r_tag = n
r_ca = ca
r_flags = code
continue
dir(sw ref): ! <n> <ca> * * * IGNORED * * *
get(n); get(ca)
continue
dir(p ref): ! <n> <ca>
get(n); get(ca)
prim entry(n) = -2
continue
dir(line reset):
get(n); current line = n-1
dir(line diag):
current line = current line+1
if diags = full start
p_ld size = p_ld size + 1
p_ld size = p_ld size + 1 unless c
0 <= current line-last line <= line diag limit
finish
last line = current line
continue
repeat
end; ! input directives
routine set prim(integer n)
integer a,j,k,base,to
error(9,n) unless 0 < n <= max prim
return if prim entry(n) >= 0
base = proc1_ca; ! current size of prim package
j = prim(n); ! entry to pointer table
k = prim(j); ! size of this prim routine
if k&x'8000' # 0 start; ! routine to be full-word aligned
base = (base+1)&(¬1)
finish
k = k & x'7FFF'; ! strip 'align' bit
prim entry(n) = base
proc1_ca = base + k*(2//2); ! halfwords
to = j+k; ! N.B. j+1:to inclusive
while j # to cycle
j = j+1; a = prim(j)&x'FFFF'
if a&x'FFF0' = emark and a # tmark start
j = j+1; a = prim(j)
set prim(a) if prim entry(a) < 0
finish
repeat
end; ! set prim
routine local stretch(record(procfm)name p)
record(deffm)name d,dd
record(reffm)name r
integer j,n,mod
return if p_ref list == null; ! no references !!
cycle
n = 0; mod = 0
r == p_ref list
cycle
local tot = local tot+1; ! *** monitoring only ***
r_ca = r_ca + mod
if r_flags&(long!rcall!safe) = 0 start
local nonsafe = local nonsafe+1; ! *** monitoring only ***
d == tagdef(r_tag)
j = r_ca
unless j-30//2 <= d_ca <= j+30//2 start
n = 1; mod = mod + (2//2)
p_ca = p_ca + (2//2)
r_flags = r_flags ! long
if j+2-16384//2 <= d_ca <= j+2+16384//2-1 start
r_flags = r_flags ! pc rel
r_flags = r_flags ! safe if |(j-d_ca)| <= safe pc rel
finish
dd == p_def list
cycle
exit if dd == null or dd_ca <= r_ca
dd_ca = dd_ca+(2//2)
dd == dd_link
repeat
finish
finish
exit if r_link = 0
r == ref(r_link)
repeat
exit if n = 0
repeat
end; ! local stretch
routine global stretch(record(procfm)name p, integername extra)
record(procfm)name pp
record(deffm)name d,dd
record(reffm)name r
integer j,k,x,n,mod,me
extra = 0 and return if p_ref list == null
x = 0
cycle
n = 0; mod = 0
r == p_ref list; Me = P_Me
cycle
global tot = global tot+1; ! *** monitoring only ***
r_ca = r_ca + mod
if r_flags&(safe!very) = 0 start
global nonsafe = global nonsafe+1; ! *** monitoring only ***
d == tagdef(r_tag)
j = p_base + r_ca
! ****** This wants cleaning up ******
if D_Proc # Me or R_Flags&rcall # 0 start
k = proc(d_proc)_base + d_ca
if j+2-16384//2 <= k <= j+2+16384//2-1 start
r_flags = r_flags ! pc rel
r_flags = r_flags ! safe if |(j-k)| <= safe pc rel
-> NEXT if R_Flags&Long # 0
finish
else
k = p_base + d_ca
finish
-> NEXT if j-30//2 <= k <= j+30//2; ! short form adequate
if r_flags&long = 0 start
r_flags = r_flags ! long
if j+2-16384//2 <= k <= j+2+16384//2-1 start
r_flags = r_flags ! pc rel
r_flags = r_flags ! safe if |(j-k)| <= safe pc rel
finish
else if (r_flags & pc rel = 0 and not 0 <= k <= 16383//2) c
or (r_flags & pc rel # 0 c
and not j+2-16384//2 <= k <= j+2+16384//2-1)
if 0 <= k <= 16383//2 start
r_flags = r_flags & (¬pc rel)
-> NEXT
finish
r_flags = r_flags ! very
else
-> NEXT
finish
!************************************
n = 1; x = x+(2//2); mod = mod+(2//2)
p_ca = p_ca + (2//2)
dd == p_def list
cycle
exit if dd_ca <= r_ca
dd_ca = dd_ca + (2//2)
dd == dd_link
repeat
pp == p
cycle
pp == pp_link; exit if pp == null
pp_base = pp_base+(2//2)
repeat
finish
NEXT:
exit if r_link = 0
r == ref(r_link)
repeat
exit if n = 0
repeat
extra = x
end; ! global stretch
routine condense
constbyteintegerarray m(0:15) =
SF, SF,
! 0 1
RX1, RX1,
! 2 3
RX2, RX2, RX2, RX2,
! 4 5 6 7
RX3, RX3, RX3, RX3, RX3, RX3, RX3, RX3
! 8 9 10 11 12 13 14 15
integer j,f
for j = 1,1,refs cycle
f = ref(j)_flags
if f&remove # 0 start
reftype(j) = 0
else
reftype(j) = m(f&15) ! ( f & (invert+rcall) )
finish
repeat
if diagnostic < 0 start
for j = 1,1,refs cycle
if (j-1)&15 = 0 start
newline; write(j,-4); print string(": ")
finish
write(reftype(j),2)
repeat
newlines(2)
finish
end; ! condense
! === for diagnostics only ===
routine dump tags
integer k
integerfn tagno(record(deffm)name d)
integer k
for k = 1,1,max tag cycle
result = k if tagdef(k) == d
repeat
signal 15,15
end
routine dump proc(integer n)
record(procfm)name p
record(deffm)Name d
integer k; k = 0
p == proc(n)
print string(" base"); write(p_base,1)
print string(" size"); write(p_ca,1)
newline
d == p_deflist
while not d == null cycle
write(tagno(d),3); print symbol(':')
write(d_ca,0)
k = k+1
newline if k&7 = 0
d == d_link
repeat
newline if k&7 # 0
end
for k = 1,1,procs cycle
newline; print string("proc"); write(k,1)
dump proc(k)
repeat
end; ! dump tags
select input(direct)
current line = 0
input directives
last proc_link == null
readsymbol(j)
error(-1, j) unless j = prog end
! read next six halfwords defining various sizes for last block:
! <code size> <literal size> <gla size> <defns> <specs> <relocations>
!===== size in halfwords
get(code size); get(literal size); get(gla size)
!===== no. of items
get(defns); get(specs); get(relocations)
error(8,ca total) if code size # ca total
for j = 1,1,max prim cycle
set prim(j) if prim entry(j) = -2
repeat
proc1_ca = proc1_ca+2; !event marker+link
dump tags if diagnostic < 0
t10 = cpu time; ! *** monitoring only ***
! Initial stretching and block allocation
! no diags in perm == proc1
!!! proc1_ld size = 0
!!! proc1_vd size = 0
pp == proc1
cycle
qq == pp_link; exit if qq == null
local stretch(qq)
qq_base = qq_base + pp_base + pp_ca
qq_ld base = pp_ld base + pp_ld size
qq_vd base = pp_vd base + pp_vd size
pp == qq
repeat
dump tags if diagnostic < 0
t11 = cpu time; ! *** monitoring only ***
! Routine calls and final stretch
cycle
n = 0
pp == proc1
cycle
pp == pp_link; exit if pp == null
global stretch(pp,extra)
if extra # 0 start
n = n+1
pp_ca = pp_ca + extra
qq == pp
cycle
qq == qq_link; exit if qq == null
qq_base = qq_base + extra
repeat
finish
repeat
exit if n = 0
repeat
dump tags if diagnostic < 0
t12 = cputime; ! *** monitoring only ***
condense; ! from ref(k)_flags -> reftype(k)
line diags = last proc_ld base + last proc_ld size
var diags = last proc_vd base + last proc_vd size
code size = last proc_base + last proc_ca
end; ! phase one
routine phase two
! generate final object file using 'tag defn' and 'ref type' tables
recordformat bfm(record(bfm)name link, integer block, c
shortintegerarray b(0:255))
recordformat sfm(integer zero addr, lower, upper, ca)
record(sfm) code, gla, ldiag, vdiag, reloc, defn, spec
constinteger bmax = 8; ! no. of da buffers (at least 2 !!)
record(bfm)array buffpool(1:bmax)
record(bfm)name buff list, bp
recordformat hdfm(shortinteger p1,p2)
recordformat headerfm(shortinteger pure size,gla size, code disp, c
lit disp, registers, main ep, c
record(hdfm) reloc, defn, spec, ldiag, vdiag)
record(headerfm) header; constinteger basic header=18; ! ** halfwords **
! formats associated with external linkage
recordformat namefm(shortinteger n1a,n1b,n2a,n2b)
recordformat xdeffm(record(namefm) n, integer ep)
recordformat specfm(integer code, gla, link)
recordformat descriptionfm(integer base,disp,type,size,form,otype, c
data size, shortinteger ident len, string(12) sym)
record(descriptionfm) xd
integer this proc; this proc = 0
integer total blocks
integer op, cond, tag, extra
integer ref; ref = 0
integer event link, ldiag link, vdiag link, defn link, spec link, asynch link
integer trace patch = 0; ! point in perm to patch in jump to $TRACE
integer j,k,l
! =================== SYSTEM DEPENDENT =====================
recordformat parmfm(shortinteger dsno,dact,ssno,sact, c
integer p1,p2,p3,p4,p5,p6)
owninteger da key = 0
constinteger da read = 9, da write = 10
routine open da(string(31)name fd, integer blocks)
record(parmfm) p,q
string(addr(p_sact)) = fd; svc(17,p); ! pack
if p_p2 < 0 start
print string(fd."?"); newline
stop
finish
q = p
p_dact = 14; svc(20,p); ! delete
p = q; p_p5 = blocks
p_dact = 2; svc(20,p); ! create
if p_p6 >= 0 start
p = q
p_p5 = 1; !permit write
p_dact = 6; svc(20,p); ! open da
da key = p_p5 and return if p_p6 >= 0
finish
print string("open da: ".string(addr(p_p1))); newline
stop
end
routine close da
record(parmfm) p
p_p5 = da key
p_dact = 11; svc(20,p)
da key = 0
return if p_p6 >= 0
print string("close da: ".string(addr(p_p1))); newline
stop
end
routine block io(record(bfm)name block, integer iofn)
record(parmfm) p
p_p4 = addr(block_b(0))
p_p5 = da key
p_p6 = block_block; ! block number req'd
p_dact = iofn; svc(20,p)
return if p_p6 >= 0
print string("block io: ".string(addr(p_p1))); write(block_block,1)
newline
signal 15,15
end
! ==========================================================
! Initialise buffer pool
buff list == null
for j = 1,1,bmax cycle
bp == buff list
buff list == buffpool(j)
buff list_block = -1; buff list_link == bp
repeat
! Initialise control records
routine set section(record(sfm)name sect, integer sect size, c
record(hdfm)name hd)
sect_zero addr = header size; header size = header size + sect size
sect_lower = 0
sect_upper = sect size
sect_ca = 0
hd_p1 = sect_zero addr; hd_p2 = 0
end; ! set section
header size = basic header
defns = defns*(3*2); ! 3 fullwords each
specs = specs*(2*2); ! 2 fullwords each
relocations = relocations*((2//2)); ! 1 halfword each
literal size = (literal size + 3)&(¬3); ! double word align
code size = code size + proc1_ca; ! allow for prim
! N.B. == defn and spec are fullword aligned in output file ==
set section(defn,defns,header_defn)
set section(spec,specs,header_spec)
set section(reloc,relocations,header_reloc)
set section(ldiag,line diags,header_ldiag)
set section(vdiag,var diags,header_vdiag)
header size = (header size+3)&(¬3); ! align literals + code
code_zero addr = header size + literal size
code_lower = -literal size
code_upper = code size
code_ca = 0
gla_zero addr = (code_zero addr + code size + h8 + 255)&(¬255); ! block align
gla_lower = 0
gla_upper = gla size
gla_ca = 0
header_registers = register template
header_main ep = -1; ! default: reset if a main program
header_code disp = code_zero addr; ! within-file disp.
header_lit disp = header size; ! within-file disp.
header_pure size = code_zero addr + code size
header_gla size = gla size
total blocks = (gla_zero addr + gla size + 255) >> 8
header_reloc_p2 = relocations; ! no. of halfwords
header_defn_p2 = defns
record(bfm)map buff(integer addr)
record(bfm)name this,last
integer block
block = addr>>8; ! ** N.B. halfword addressing units, 512 byte block **
result == buff list if block = buff list_block
buff miss1 = buff miss1+1; ! *** monitoring only ***
if diagnostic < 0 start
printstring("block"); write(block,1); newline
finish
last == buff list
cycle
buff miss3 = buff miss3+1; ! *** monitoring only ***
this == last_link
-> promote if this_block = block
exit if this_link == null
last == this
repeat
if this_block < 0 start; ! buffer still free
this_block = block
else
block io(this,da write)
this_block = block
block io(this,da read)
buff miss2 = buff miss2+1; ! *** monitoring only ***
finish
promote:
last_link == this_link
this_link == buff list
buff list == this
result == buff list
end; ! of 'buff'
routine flush buffers
record(bfm)name this
integer k
this == buff(0)
if h8 # 0 start
this_b(0) = (header_pure size + h8 + 255)//256
this_b(1) = (header_gla size + 255)//256
this_b(2) = x'4321'; ! new format identifier
this_b(3) = 0; this_b(4) = 0; this_b(5) = 0
this_b(6) = 0; ! flags
this_b(7) = 0; ! stack
finish
for k = 0,1,basic header-1 cycle
this_b(k+h8) = short integer(addr(header)+k*2)
repeat
this == buff list
cycle
block io(this,da write) if this_block >= 0
this == this_link
exit if this == null
repeat
end; ! flush buffers
routine origin(record(sfm)name section, integer org)
if diagnostic < 0 start
if diagnostic <= -2 start
print string("ORG:"); write(org,1)
write(section_lower,6); write(section_upper,1)
newline
finish
finish
section_ca = org and return if section_lower <= org <= section_upper
error(25,org)
end
routine put(record(sfm)name section, shortinteger item)
record(bfm)name bp
integer addr
owninteger last = -1
addr = section_zero addr + section_ca
addr = addr + h8 unless section == gla
if diagnostic < 0 start
if diagnostic < -2 start; ! two-stage test for speed
newline if addr # last+1
last = addr
write(addr,4); print string(": "); phex(item)
newline
finish
finish
bp == buff(addr)
bp_b(addr&255) = item
section_ca = section_ca + 1
end; ! of 'put'
routine put name(record(sfm)name sect)
integer j; shortinteger half
integerfn ch(integer sym)
result = sym-'A'+1 if 'A' <= sym <= 'Z'
result = sym-'a'+1 if 'a' <= sym <= 'z'; ! ** lower case alphabet **
result = sym-'0'+27 if '0' <= sym <= '9'
result = sym-'#'+37 if '#' <= sym <= '%'; ! 37='#', 38='$', 39='%'
result = 0 if sym = ' '
result = -1
end; ! ch
routine pack3(integer k, shortintegername n)
integer p,q,r
p = charno(xd_sym,k); q = charno(xd_sym,k+1); r = charno(xd_sym,k+2)
n <- ( (ch(p)*40 + ch(q))*40 + ch(r) ); ! ugh!!!
end; ! pack3
charno(xd_sym,j) = ' ' for j = length(xd_sym)+1,1,xd_ident len
for j = 1,3,xd_identlen-2 cycle
pack3(j,half); put(sect,half)
repeat
end; ! put name
routine set description(integer desc type)
integer sym,j,k,l, char
read symbol(k)
l = k; l = 12 if l > 12
length(xd_sym) = l
for j = 1,1,l cycle
readsymbol(char)
char = char - 'a' + 'A' if c
'a' <= char <= 'z'
charno(xd_sym,j) = char
repeat
k = k-l
skip symbol and k = k-1 while k > 0
xd_ident len = 12; ! assume full 12-character ident.
return if desc type = proc header; ! only ident. present
xd_identlen = 6 if l <= 6 and desc type = diag entry
read symbol(xd_otype)
read symbol(k)
xd_type = k>>4; xd_form = k&15
read symbol(j); get(k)
xd_base = j>>4
xd_disp = (j&15)<<16 + (k&x'FFFF')
if diagnostic < 0 start
print string(xd_sym.": "); write(xd_identlen,1)
write(xd_base,1); write(xd_disp,4)
write(xd_type,3); write(xd_form,1); write(xd_otype,1)
newline
finish
end; ! set description
routine insert prims
integer j,k,l,m,to
for j = 1,1,max prim cycle
k = prim entry(j)
if k >= 0 start
if diagnostic < 0 start
print string("prim"); write(j,1); print symbol(' '); phex(k)
newline
finish
origin(code,proc1_base + prim entry(j))
k = prim(j)
to = k + prim(k) & x'7FFF'; ! strip 'align' bit
while k # to cycle
k = k+1; m = prim(k)&x'FFFF'
if m&x'FFF0' # emark start
put(code,m)
else if m = tmark; ! trace routine external call
trace patch = code_ca
put(code,m)
else
if m&15 = 8 start
put(code, jmp)
else
put(code, bal + (m&15)<<4)
finish
k = k+1; m = prim(k)
l = prim entry(m); ! pointer to referenced routine
error(15,j) if l < 0
put(code,(proc1_base+l)*2); ! byte displacement
finish
repeat
finish
repeat
asynch link = prim entry(max prim); ! *** must be last entry in perms ***
end; ! 'insert prims'
routine plant code ref
integer j,k,l,t,there
record(deffm)name d
switch format(SF:RX3)
ref = ref+1; t = reftype(ref)
d == tagdef(tag)
there = proc(d_proc)_base + d_ca + extra
cond = cond+6 if t&invert # 0
op = long jump(cond) if t&rcall = 0
-> format(t&7)
format(SF): ! short format
sfjump = sfjump+1
l = 0; k = there-code_ca; ! halfword disp. req'd here
if k < 0 start
l = backwards; k = -k
finish
error(200,code_ca) if k > 15; ! error in reference table
put(code,(short jump(cond) !! l) + k)
return
format(RX1):
rx1jump = rx1jump+1
format(RX3):
rx13jump = rx13jump+1
k = (there - proc1_base)*2; ! byte disp. from code base
put(code, op)
if t&7 = RX3 start
put(code, x'4000'!((k>>16)&15))
else
error(201,code_ca) unless 0 <= k <= 16383
finish
put(code,k&x'FFFF')
return
format(RX2):
rx2jump = rx2jump+1
k = (there - (code_ca+4//2))*2
error(202,code_ca) unless -16384 <= k <= 16383
put(code, op&(¬15))
put(code,halfword sign ! k)
end; ! 'plant code ref'
routine dump code
owninteger depth = 0
integer last line, last ca
integer code reset
owninteger lit reset; ! no recursion!! - literals are not exbedded
owninteger last spec = 0, gla skip = 0
record(procfm)name p
integer cca, lca, vca
integer k,c,half
switch dir(1:extern)
depth = depth+1
this proc = this proc+1
p == proc(this proc)
origin(code,p_base); origin(ldiag,p_ldbase); origin(vdiag,p_vdbase)
last ca = code_ca; last line = 0
if this proc # 1 start; ! its a recursive call
! DIAGS: dump procedure line origin and identifier
get(last line); set description(proc header)
if diags # none start
k = last line
k = 0 if hide # 0
put(ldiag,k); put name(vdiag)
finish
else; ! initial (non-recursive) call
if diags # none start
xd_sym = "PERM"; xd_identlen = 12
put(ldiag,0); put name(vdiag)
finish
insert prims
origin(code,proc1_base+proc1_ca-2)
put(code,code_ca - event link); ! link round perm
event link = code_ca - 1
put(code,x'8000'); ! dummy event mask
finish
cycle
read symbol(c)
-> dir(c) if 0 < c <= extern
!!dir(*):
error(12,c)
dir(proc head):
read symbol(k); error(13,k) unless k = this proc
cca = code_ca; lca = ldiag_ca; vca = vdiag_ca
dump code
origin(code,cca); origin(ldiag,lca); origin(vdiag,vca)
continue
dir(proc end):
depth = depth-1
if depth # 0 start; !not in perm
! dump event chain
put(code,code_ca-event link); ! here relative link to preceding block
event link = code_ca-1
if p_event mask = 0 start
put(code,p_display reg ! halfword sign)
else
put(code,p_display reg)
put(code,p_event mask)
put(code,tagdef(p_event start)_ca + p_base)
put(code,tagdef(p_event finish)_ca + p_base)
finish
finish
! dump line diag. table link
!!!!!!!!!! last line = -line diag limit-1
if diagnostic < 0 start
write(ldiag_ca,1)
write(p_ldbase,1); write(p_ldsize,1); newline
finish
if diags = full start
if depth = 0 start; !special for perm
put(ldiag, proc1_ldsize)
put(vdiag, proc1_vdsize)
else
put(ldiag, ldiag_ca-ldiag link); ! relative to here
ldiag link = ldiag_ca - 1
put(vdiag, vdiag_ca-vdiag link); ! ... ditto ...
vdiag link = vdiag_ca - 1
finish
k = p_ld base + p_ld size; put(ldiag,0) while ldiag_ca # k; ! zero
finish
return
dir(code area):
lit reset = code_ca
code_ca = code reset
continue
dir(lit area):
code reset = code_ca
code_ca = lit reset
continue
dir(lit org):
get(half)
lit reset = -half
continue
dir(code item):
get(half)
put(code,half)
continue
dir(gla item):
get(half)
gla skip = gla skip-1 and continue if gla skip # 0
put(gla,half)
continue
dir(gla rel):
! Assumed to immediately follow the dumping of the GLA full-word to
! which it refers.
put(reloc,gla_ca-2); ! N.B. -2 halfwords = -4 bytes
continue
dir(code rel):
! As for GLA REL but modifies a word in gla according to the value of
! code base at load time
put(reloc,(gla_ca-2)+1); ! N.B ** odd-numbered halfword => code seg **
continue
dir(frame patch):
origin(code,code_ca-1)
put(code,p_static frame); ! bytes if TRUSTED else fullwords
continue
dir(c ref):
dir(j ref): ! jumps
skip symbol; ! 'code item'
get(half)
cond = half&15; tag = half>>4
extra = 0; ! to match r ref path!!
plant code ref
continue
dir(r ref): ! procedure calls (including %begin-%end blocks)
get(tag)
skip symbol; ! 'code item'
get(op)
skip symbol; ! 'code item'
get(extra)
cond = 0
plant code ref
continue
dir(p ref): ! prim call
skip symbol; ! 'code item'
get(op)
skip symbol; ! 'code item'
get(k)
error(15,k) unless 0 < k <= max prim
put(code,op)
put(code,prim entry(k)*2 ); ! byte disp.
continue
dir(sw ref):
skip symbol; ! 'code item'
get(tag)
k = tag def(tag)_ca; k = k + p_base if k # 0
put(code,k); ! N.B. halfwords relative to code base
continue
dir(line reset):
get(half)
current line = half-1; ! * see below *
dir(line diag):
current line = current line + 1
if diagnostic < 0 start
print string("line"); write(current line,1); write(code_ca,1)
newline
finish
ca incr = code_ca - last ca
continue if ca incr = 0
line incr = current line - last line
unless 0 <= line incr <= line diag limit start
put(ldiag, (current line-1) ! halfword sign ) if diags = full
line incr = 1
finish
put(ldiag, ca incr*(line diag limit+1) + line incr) if diags = full
last line = current line
last ca = code_ca
continue
dir(var diag):
set description(diag entry)
if diags = full start
k = ((xd_type&7)<<4 + xd_base&15)<<4 + (xd_disp>>16)
k = k!halfword sign if xd_identlen # 12; ! ...%if a short ident
k = k!indirect if xd_form = 2; ! %name variable
k = k!x'2000' if xd_type&8 # 0
put(vdiag,k); put(vdiag,xd_disp&x'FFFF')
put name(vdiag)
finish
continue
dir(extern):
! <=== word 1 =====> <======== word 2 ======> <== word 3 =>
! ------------------ ------------ ----------- -------------
! Proc spec: | link to previous | identifier : self-link | x'00000000' |
! ------------------ ------------ ----------- -------------
! ------------------ ------------ ----------- -------------
! Data spec | link to previous | identifier : ????????? | x'80000000' |
! ------------------ ------------ ----------- -------------
read symbol(c); ! type of cross reference
get(xd_data size)
set description(linkage name)
gla skip = 0
if c = ep defn or c = data defn start
k = xd_disp
if c = ep defn start
k = code_ca
if xd_sym = main ep start
p_display reg = p_display reg ! main prog
header_main ep = k
finish
finish
put(defn, defn link); defn link = header_defn_p1 + defn_ca-1; ! file relative
put(defn, k)
put name(defn)
else if c = ep spec or c = data spec
if trace patch # 0 and xd_sym = trace ep start
c = code_ca
origin(code,trace patch)
put(code,gla_ca*2); !halfwords note.
origin(code,c)
finish
k = header_spec_p1 + spec_ca; ! file relative
put name(spec)
put(gla,spec link>>16); put(gla,spec link); ! gla relative back link
spec link = gla_ca - 2
put(gla,k)
put(gla,gla_ca-3); ! halfword disp. of this block into GLA
if c = data spec start
put(gla, -1); put(gla, -1)
else
put(gla, 0); put(gla, 0)
finish
gla skip = 6; ! half words
else
error(170,c)
finish
continue
repeat
end; ! of 'dump code'
select input(object)
open da(IMPCOM_file,total blocks)
!!!! read symbol(j); put(gla,x'7FFF') %for j = 1,1,j; ! init gla
! Dual standard meantime for first words in gla
read symbol(j); put(gla,x'7FFF') for j = 1,1,j-2
put(gla,0); put(gla,0)
read symbol(j); error(17,j) if j < init lit; ! pass2 INIT LIT value
current line = 0
event link = -1
ldiag link = proc1_ldsize-1
vdiag link = proc1_vdsize-1
defn link = 0
spec link = 0
dump code
readsymbol(j)
error(-2,j) unless j = prog end
origin(code,-init lit); ! = -4: must always dump the exact number
put(code,0); ! *** padding ***
put(code,asynch link); ! signal relative to code base
put(code,header_code disp); ! code base addr - file start addr
put(code,event link)
if diags # full start; ! no links embedded in tables!!!
if diags = partial start
header_ldiag_p1 = header_ldiag_p1 ! halfword sign
ldiag link = this proc*(2//2); ! halfword size: for use below
vdiag link = this proc*8//2; ! ditto
else; ! 'none'
header_ldiag_p1 = 0; ! no diag tables present
finish
finish
header_ldiag_p2 = ldiag link; ! ldiag_p1+ldiag_p2 => start of chain
header_vdiag_p2 = vdiag link
header_spec_p2 = spec link; ! GLA relative
header_defn_p2 = defn link; ! N.B. FILE relative
flush buffers
close da
end; ! phase two
!========================================================================
diags = (IMPCOM_flags >> 8)&7; ! * * * * SYSTEM DEPENDENT * * * *
hide = IMPCOM_flags&x'0800'
!========================================================================
select output(report)
t0 = cpu time; ! *** monitoring only ***
diags = full if diags > full
phase one
t1 = cpu time; ! *** monitoring only ***
phase two
t2 = cpu time; ! *** monitoring only ***
IMPCOM_code = (code size+literal size-proc1_ca)*2
IMPCOM_perm = proc1_ca*2
IMPCOM_gla = gla size*2
IMPCOM_diags = (line diags+var diags)*2
! print string("Jumps:")
! write(sfjump,1); print string(" SF +")
! write(rx1jump,1); print string(" RX1 +")
! write(rx2jump,1); print string(" RX2 +")
! write(rx13jump-rx1jump,1); print string(" RX3 =")
! write(sfjump+rx2jump+rx13jump,1)
! newline; print string("Diagnostic Tables (bytes):")
! print string(" line"); write(line diags*2,1)
! print string(", ident"); write(var diags*2,1)
! newlines(2)
! print string("Millisecs: phase1 "); write(t1-t0,1)
! print string(" phase2"); write(t2-t1,1)
! newline
! %if local tot # 0 %and global tot # 0 %start
! print string("Stretching - safe/total (%) local:")
! write( (local tot-local nonsafe)*100//local tot, 4)
! print string(" global:")
! write( (global tot-global nonsafe)*100//global tot,4)
! newline
! %finish
! spaces(15)
! print string("millisecs:"); write(t11-t10,14); write(t12-t11,13)
! newline
! print string("Total output (halfwords):")
! write(code size+literal size+gla size+var diags+line diags, 1)
! newline
! print string("Disc buffer: searches"); write(buff miss1,1)
! print string(" cache misses"); write(buff miss2,1)
! newline
! print string("Mean search length="); print(buff miss3/buff miss1,1,2)
! newline
endofprogram