!!%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 ! ************************************************************** ! * * ! * PERKIN-ELMER 32-bit series IMP compiler * ! * Intermediate-code Assembler * ! * * ! * (General Service Version) * ! * * ! * Interactive Datasystems (Edinburgh) Ltd. * ! * 32, Upper Gilmore Place, * ! * Edinburgh EH3 9NJ * ! * * ! * Copyright (c) MAY 1st. 1980 * ! * All Rights Reserved * ! * * ! ************************************************************** ! Known faults: ! Outstanding: ! %longreal is currently treated as %real ! statically sized arrays within stack frame ! ! Optimisations: (intended complete list) ! integer constant folding *done* ! real folding: integer/integer, integer^integer *done* ! literals in shareable code segment *done* ! special treatment of null string *done* ! special treatment of simple append (S = S.T) *done* ! special treatment of S=S.tostring(x) *done* ! suppression of redundant capacity checks *done* ! suppression of redundant unassigned checks *done* ! register usage *done* ! register environments *done* ! k*2 -> k+k, k^2 -> k*k, k^^2 -> k*k *done* ! Pass last param = string or record %value as %name then ! copy within routine *done* (for strings only) ! Detect and omit redundant array bound checks ! ABORT CODES ! =========== ! code routine reason ! ! ?? x: assemble: faulty intermediate code operation 'x' ! ADMP: adump: constant record ? ! AM00: assemble: static block nesting > 5 levels ! AM01: assemble: ('A') unknown constant type ! AM05: assemble: ('u', 'q') unspecified length in ++, -- ! AM10: assemble: ('_') switch label outwith declared vector ! AM15: assemble: ('B') intermediate code faulty at %repeat tag ! AM25: assemble: ('F') user label out of range ! AM30: assemble: (':') user label out of range ! AM35: assemble: ('d') wrong no. of dimensions specified ! AM40: assemble: ('d') %const/%own array inside out ! AM45: assemble: ('~') faulty intermediate code in alternate record format ! AM50: assemble: ('}') symbol table overflow (inserting formal parameter specs) ! AM55: assemble: ('}') (OUT:) %record format > 64k bytes ! AMAP: amap: impossible form ! ARF1: array ref: no. of subscripts doesn't match declaration ! ASS1: assign: not at least two items on operand stack ! ASS2: assign: general %name not a %name ! ASS3: assign: record length undefined in 'record = record' ! CLM1: claim: reg > fr14 ! CLMD: assemble: ('O') registers still claimed at line flag ! COP1: cop: exponent overflow in folding integer^integer ! COP2: cop: inappropriate operator ! DMP1: select literal area: literal area already selected ! DMP2: select code area: code area already selected ! DMP3: lit byte: literal area not selected ! DMP4: claim literal: literal area currently selected ! DMP5: external link: non-existent reference type ! DROP: drop: descriptor not in use ! DSC1: descriptor: operand stack overflow ! DSC2: descriptor: descriptor free-list empty ! DSC3: descriptor: link-block ('using') free-list empty ! DFV1: define var: symbol table overflow (inserting record element name) ! DFV2: define var: symbol table overflow (inserting non-format item) ! FOR1: compile for: too many nested %for...%cycle .....%repeat pairs ! HAZ1: hazard: attempt to hazard a constant ! HAZ2: hazard: a use is still outstanding ! HDR1: header: %string parameter in %begin ? ! LD1: load: ADDRESS failed to simplify non-trivial address mode ! LD2: load: real variable/integer register ! LD3: load: inappropriate type ! LD4: load: not/neg implemented in operate ! LD5: load: load floating variable into 'any' ? ! LD6: load: real operand with and/or/xor ! LD7: load: real 'neg' implemented in operate ! LD8: load: not a floating register ! LD9: load: real exponent ? ! LIT?: assemble: ('O') literal area still selected at line flag ! NLBL: new label: no free labels ! PICK: pickup (in LOAD) incompatible uses of a register ! POPL: pop lhs: operand stack is already empty ! REL1: release: reg > fr14 ! REL2: release: reg not claimed ! RXD1: rxd: no immediate form of instruction ! RXD2: rxd: faulty register specification ! RXD3: rxd: faulty register specification ! RXD4: rxd: non-elementary operand type supplied to 'RXD' ! RXD5: rxd: displacement not aligned on 'type' boundary ! SETB: set both: not at least two items on operand stack ! STK?: assemble: ('O') operand stack not empty at line flag. ! TAG?: block mark: more than 32767 third pass tags generated. See c('_'): ! USNG: assemble: ('O') 'using' list not empty at line flag. ! VMAP: vmap: impossible form ! VSTK: vstack: variable no (symbol table index) out of bounds ! == == == == == == == == == == == == == == == == == == ! Known Faults: ! READ SYMBOL is not implemented properly ! external linkage dumping is too indiscriminate ! general name parameter types don't match old subsystem ! == == == == == == == == == == == == == == == == == == !***************************************************************************** ! ! Options: (enabled when control bit = 1) ! ! 1: Capacity check on all store operations ! Overflow check on integer multiply ! 2: Unassigned check on %string, %integer, %real & %longreal operands ! 4: Array bound checking ! Checks for integrity of %for construction ! 16: Assorted extra checks: ! complete arithmetic overflow checking (*not yet*) ! 32: Permit removal of ALL diagnostic code and optimisations which are ! not 100% safe. ! Diagnostic code removed: ! Unassigned check on P in R string parameter ! Stack limit check ! Risky optimisations: ! Remembering pointers over an assignment via ! another pointer. Aliasing might JUST occur. ! 64: Enable trace option ! 128: No register optimisation: primarily for suppressing compiler faults ! ! NOTE: ! Switch references are always checked ! Stack overflow is checked unless 'TRUSTED' is specified. ! !****************************************************************************** ! N.B. The bit positions in CONTROL corresponding to 256 and 512 ! are reserved to control the dumping of diagnostic tables ! by PASS 3. ! ! OPT is set (implicitly) by disabling all explicitly settable ! checks (bits 1,2,4,8,16) ! ! TRUSTED disables all checks and also sets the '32' bit. !****************************************************************************** %begin; ! 7/32 DIAGNOSTIC ASSEMBLER !SIZE CONSTANTS %constinteger max vars = 800 %constinteger max labels = 80 %constinteger max depth = 16 %constinteger max stack = 25 %constinteger max labdef = 7999 %constinteger max refs = 2000 %constinteger SetLen = 32 {bytes per set} %constinteger max prim = 23 %constinteger max cycle = 30 %constinteger max temps = 60 %constinteger max use = 20; !limit for klist %constinteger max envirs = 5; !Environments %constinteger max knowledge = max use*(max envirs+1) %conststring(3) program ep = "%GO"; ! Main program external name %conststring(1) system prefix = "$"; ! prefixed to %system routine idents %conststring(6) trace routine = "$TRACE"; ! external called by trace option %conststring(10) read sym fn = "#READSYMFN"; ! linkage name of "read symbol" perm %constinteger ident len = 19; ! Significant chars in internal idents %constinteger extern len = 12; ! Max. length of names in diags/link !Input/output streams %constinteger in=1 %constinteger report=0, direct=1, object=2 ! Language mask bits (generally =0 for 'obvious' or IMP interpretation) ! Note that each bit controls compilation of a particular source level ! abstraction and each first pass can select any convenient combination ! of options. %constinteger UNUSED = 1, {currently not used - IMP pass1!!} non IMP for = 2 {exit on >= final value (zero trip)} !CONTROL BITS %constinteger check capacity=1 %constinteger check unass=2 %constinteger check array=4, check for = 4 %constinteger check extra=16 %constinteger trusted=32 %constinteger trace=64 %constinteger suppress=128 %constinteger check bits = check capacity+check unass+check array+check extra %constinteger bit15 = -32768; ! halfword sign-bit !SPECIAL ADDRESSES %constinteger unass = 12; ! unassigned pattern at unass(code) %constinteger init gla = 12; ! first usable displacement into gla %constinteger init lit = 8; ! first literal ends at -INITLIT(CODE) ! Derived constants %constinteger for lab base = 8000; ! = MAX LABDEF+1 !REGISTERS %constinteger R0 = 1 %constinteger R1 = 2; ! Fn/map result, @final string result %constinteger p3 = R1; ! SPECIAL STRING PARAMETER %constinteger R2 = 3 %constinteger R3 = 4 %constinteger R4 = 5 %constinteger R5 = 6, p2 = R5 %constinteger R6 = 7, p1 = R6 %constinteger R7 = 8, wsp = R7 %constinteger R8 = 9, base1 = R8 %constinteger R9 = 10, base2 = R9 %constinteger R10 = 11, base3 = R10 %constinteger R11 = 12, base4 = R11 %constinteger R12 = 13, base5 = R12; ! (unassigned pattern for levels 1:4) %constinteger R13 = 14, gla = R13 %constinteger R14 = 15, code = R14 %constinteger R15 = 16, link = R15 %constinteger FR0 = 17; ! FN RESULT %constinteger FR2 = 18 %constinteger FR4 = 19 %constinteger FR6 = 20 %constinteger FR8 = 21 %constinteger FR10 = 22 %constinteger FR12 = 23 %constinteger FR14 = 24 !PSEUDO REGISTERS %constinteger any = 25 %constinteger anyf = 26 %constbyteintegerarray actual(0:fr14) = 0, 0, 1, 2, 3, 4, 5, 6, 7, ! R0 R1 R2 R3 R4 P2 P1 WSP 8, 9, 10, 11, 12, 13, 14, 15, ! R8 R9 R10 R11 R12 GLA CODE LINK 0, 2, 4, 6, 8, 10, 12, 14 ! FR0 FR2 FR4 FR6 FR8 FR10 FR12 FR14 %constbyteintegerarray breg(-1:5) = 0, 0, base1, base2, base3, base4, base5 !DATA FORMS ! EXTERNAL %constinteger recordformat = 4 %constinteger switch = 6 %constinteger array = 11 %constinteger arrayname = 12 %constinteger namearray = 13 %constinteger namearrayname = 14 ! INTERNAL %constinteger constant = 0 %constinteger v in r = 1 %constinteger av in r = 2 %constinteger a in r = 3 %constinteger v in s = 4 %constinteger av in s = 5 %constinteger a in s = 6 %constinteger v in rec = 7 %constinteger av in rec = 8 %constinteger a in rec = 9 %constinteger pgm label = 14 !!N.B. FORM=15 denotes %record format ! Flag bits used in conjunction with form: %constinteger quick conc = 1, {optimise: S = S.tostring(symbol) } P in R = 2, {parameter-in-register} prim bit = 4, {primitive known to compiler} assigned = 8, {assigned and known to be} proc bit = 16, {routine/fn/map/predicate} abit = 32, {array by value} anbit = 64, {array by name} label bit = 128 {data is an address} %constinteger array bits = abit ! anbit; ! for convenience ! All arrays are in fact treated as by name (i.e. with a dope vector) and ! the ABIT bit is misused to indicate that an array is a candidate for ! subscript scaling by the use of 'multiply halfword' %constinteger cheap array bit = abit ! 'FLAG' byte of 'xform': !=======================================================================! ! label AN A proc assigned prim P in R ------ ! ! bit bit bit bit bit ! ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ! 128 64 32 16 8 4 2 1 ! !=======================================================================! ! : ! ! : D I M E N S I O N S ! ! : (if %array) ! ! :______________________________! ! N.B. ! In 'varfm' the 4,2,1 bits are used to hold the number of dimensions ! when the table entry represents an array object. This field is ! unpacked into the 'DIM' field of 'stackfm' by 'VSTACK' !LABEL CONSTANTS %constinteger define new = 0 %constinteger redefine old = 1 %constinteger internal tag = -1; ! N.B. This must be <0 and others >=0 !DATA TYPES %constinteger integers = 1 %constinteger short = 2 %constinteger byte = 3 %constinteger general = 4 %constinteger strings = 5 %constinteger records = 6 %constinteger reals = 7 %constinteger reall = 7; ! (SET TO 8 FOR LONG REALS) !Figurative data types used internally (reduce to INTEGERS) !! %constinteger pointer = -1 !! %constinteger in store const = -2 !LENGTHS %constinteger single=4; ! bytes in single precision %real %constinteger double = single*(reall-reals+1) %constinteger align = 3; ! Basic alignment mask %constinteger reglen=4; ! no. of bytes in GP register %constinteger basic frame = (link-p2+1)*reglen !OWN INFO %constinteger own = 1 %constinteger con = 2 %constinteger external = 3 %constinteger system = 4 %constinteger dynamic = 5 %constinteger primrt = 6 %constinteger permrt = 7 ! Constants used to define sizes of various objects known to pass 3 %constinteger short ident = 6; ! characters: related to 'extern len' !! %constinteger basic vdiag = 4; ! halfwords: no. req'd for 'short ident' %constinteger extra vdiag = 2; ! halfwords: basic+extra == extern len ! Define type codes known externally (to pass 3 and user): %constbyteintegerarray gen map(integers:reals+1) = 1, 6, 5, 0, 3, 4, 2, 8 ! integer short byte general string record reals reall !PERM ROUTINES ! ** UNASSIGNED CHECK as a special at 0(code) ** %constinteger asschk=1 %constinteger iexp=2 %constinteger fexp=3; ! floating exponent %constinteger smove=4 %constinteger sjam=5 %constinteger sconc=6 %constinteger sresln=7; ! conditional resolution %constinteger sresv=8; ! check SRESLN succeeded %constinteger scomp=9 %constinteger frac part = 10; ! IMP 'frac pt' function %constinteger sfcap=11; ! string capacity exceeded %constinteger substr = 12; ! substring %constinteger aref1=13; ! 1-D with checks %constinteger aref2=14; ! 2-D with checks %constinteger aref3=15; ! n-D with checks %constinteger aref4=16; ! 2-D without checks %constinteger set dv=17; ! set dope vector %constinteger alloc=18; ! claim array space %constinteger swjump=19 %constinteger signal=20 %constinteger mulchk=21; ! check for 32-bit result from integer multiply %constinteger cap16=22; ! check for 16-bit signed overflow %constinteger cap8=23; ! . . . 8-bit unsigned . . %constinteger fchk1=24; ! %for loop parameter check %constinteger fchk2=25; ! check for %for loop counter fiddling %constinteger pentc=26; ! checked procedure entry %constinteger rcopy=27; ! record copy %constinteger rzero=28; ! clear record %constinteger vschk=29; ! variable shift parameter check %constinteger smovopt=30; ! fast unchecked string move (also see P in R string) %constinteger chmap=31; ! IMP 'charno' %map %constinteger freesp=32; ! IMP 'free space' function %constinteger int fn=33; ! IMP 'int' function %constinteger rcomp = 34 {record compare} %constinteger set comp = 35, set union = 36, set difference = 37, set intersection = 38 %constbytearray Set ops(1:3) = Set union, Set Difference, Set intersection %constinteger iocp = 49 %constinteger enter trace = 50 !OPERATIONS ! logical => both <= code generator %constinteger not = 1, lw = 1 %constinteger neg = 2, st = 2 %constinteger add = 3 %constinteger sub = 4 %constinteger mul = 5 %constinteger div = 6 %constinteger conc = 7, cmp = 7 %constinteger and = 8 %constinteger or = 9 %constinteger xor = 10 %constinteger lsh = 11 %constinteger rsh = 12 %constinteger mult16 = 13 %constinteger rem = 14 %constinteger exp = 15 %constinteger rexp = 16 %constinteger rdiv = 17 !CODE GENERATOR TABLES ! mask bits in 'op index' array %constinteger fw imm=2048, hw imm=4096, sf imm=8192, inv imm=16384 %constinteger fw rr=256, fw rx=512, short rx=1024, byte rx=32768 %constinteger fp base = rem-1 %constshortintegerarray op index(1:40) = x'FF01',; ! LW: load - 1 + all formats x'8609',; ! ST: store - 9 + full/half word + byte x'7F11',; ! ADD: add - 17 + all but byte x'7F18',; ! SUB: subtract - 24 + all but byte x'031F',; ! MUL: multiply - 31 + full word formats x'0321',; ! DIV: divide - 33 + full word formats x'1F23',; ! CMP: compare - 35 + all but byte and short immediate x'1F28',; ! AND: and - 40 + ..... x'1F2D',; ! OR: or - 45 + ...... x'1F32',; ! XOR: xor - 52 + ........ x'3037',; ! LSH: left shift - 55 + halfword and shortform x'303D',; ! RSH: right shift - 61 + halfword and shortform x'0775',; ! MULT16: 117 + rr + rx + short rx ! ** floating point formats ** x'0F43',; ! LW: load - single and double x'0A47',; ! ST: store - store reference formats only x'0F4B',; ! ADD: add - 75 + all formats x'0F4F',; ! SUB: subtract - 79 + ... x'0F53',; ! MUL: multiply - 83 + ... x'0F57',; ! DIV: divide - 87 + ... x'0F5B',; ! CMP: compare - 91 + ... ! ** specials ** x'0364', ; ! JMP x'0366', ; ! BAL x'0267', ; ! LA x'0268', ; ! LM x'0269', ; ! STM x'016B', ; ! FLR x'016C', ; ! FXR x'1F5F', ; ! CLW x'1069', ; ! SRA x'016E', ; ! CHVR x'016F', ; ! LBR x'040A', ; ! STH x'026F', ; ! SVC x'0270', ; ! LME x'0271', ; ! STME x'1870', ; ! TEST (TI/THI) x'0476', ; ! LHL (short rx only) x'0678', ; ! AM (fullword and short rx only) x'027A', ; ! TBT x'027B' ; ! SBT ! Each halfword below is treated as 4 groups of 4 bits [a:b:c:d] with the ! following significance. ! a,b: 8-bit machine op-code ! c: special function bits ! 1: this operation sets condition code other than relative ! to zero. ! 2: invert order of operands to provide for example ! STR x,y => LR y,x ! 4: this operation doesn't affect condition code ! d: mask to check alignment of displacement required by this instruction. %constshortintegerarray op code(1:124) = x'0800', x'5803', x'4801', x'F800', x'C800', x'2400', x'2500', x'D350', ! LR L LH LI LHI LIS LCS LB x'0820', x'5053', x'4051', 0, 0, 0, 0, x'D250', ! STR ST STH -- -- -- -- STB x'0A00', x'5A03', x'4A01', x'FA00', x'CA00', x'2600', x'2700', ! AR A AH AI AHI AIS SIS x'0B00', x'5B03', x'4B01', x'FB00', x'CB00', x'2700', x'2600', ! SR S SH SI SHI SIS AIS x'1C50', x'5C53', ! MR M x'1D50', x'5D53', ! DR D x'0910', x'5913', x'4911', x'F910', x'C910', ! CR C CH CI CHI x'0400', x'5403', x'4401', x'F400', x'C400', ! NR N NH NI NHI x'0600', x'5603', x'4601', x'F600', x'C600', ! OR O OH OI OHI x'0700', x'5703', x'4701', x'F700', x'C700', ! XR X XH XI XHI 0, 0, 0, 0, x'ED00', x'1100', ! -- -- -- -- SLL SLLS 0, 0, 0, 0, x'EC00', x'1000', ! -- -- -- -- SRL SRLS x'2800', x'6803', x'3800', x'7803', ! LER LE LDR LD x'2820', x'6053', 0, x'7053', ! STER STE -- STD x'2A00', x'6A03', x'3A00', x'7A03', ! AER AE ADR AD x'2B00', x'6B03', x'3B00', x'7B03', ! SER SE SDR SD x'2C00', x'6C03', x'3C00', x'7C03', ! MER ME MDR MD x'2D00', x'6D03', x'3D00', x'7D03', ! DER DE DDR DD x'2910', x'6913', x'3910', x'7913', ! CER CE CDR CD ! Special purpose entries. x'0510', x'5513', x'4511', x'F510', x'C510', ! CLR CL CLH CLI CLHI x'0300', x'4300', ! BFCR BFC x'0100', x'4100', ! BALR BAL x'E650', ! LA x'D150', ! LM x'D050', ! STM x'2F00', ! FLR x'2E00', ! FXR x'EE10', ! SRA x'1200', ! CHVR x'9350', ! LBR x'E110', ! SVC x'7250', ! LME x'7150', ! STME x'F310', x'C310', ! TI THI x'0C50', x'4C51', x'4C51', ! MHR M(H) MH x'7301', ! LHL x'5113', x'6111', ! AM AHM x'7401', x'7501' ! TBT SBT !Non-uniform operations for special situations %constinteger jmp=21, always=r0; ! RR(JMP,always,LINK) %constinteger bal=22; ! Branch-and-link %constinteger la =23; ! Load Address (RX format) %constinteger lm=24, stm=25; ! Load/Store Multiple ! ** FLR below is really 25-fpbase ** %constinteger flr=26-fpbase, fxr=27; ! Float/Fix (RR format only) %constinteger clw=28; ! Compare Logical (same formats as AND) %constinteger sra=29; ! Shift Right Arithmetic (HW IMM only) %constinteger chvr=30; ! Convert to halfword value (RR only) %constinteger lbr=31; ! Load Byte Register (RR only) %constinteger sth=32; ! Store half-word (Short RX only) %constinteger svc=33; ! Supervisor call (RX format) %constinteger lme=34-fpbase; ! Used in conjunction with SVC %constinteger stme=35-fpbase; ! .... ditto .... %constinteger test=36; ! test halfword? immediate %constinteger LHL=37; ! load unsigned halfword (for switch) %constinteger AM=38; ! add-to-memory (see ASSIGN) %constinteger TBT = 39, SBT = 40 %constbytearray Inverted(16:21) = 0, 1, 3, 2, 5, 4 { = # < > <= >= } !ASSORTED FUNNY CONSTANTS %constinteger jump=12; ! logical condition code == unconditional jump %constinteger not equal=1; ! . . . branch not equal %constinteger less than=2, greater than=3 %constinteger less or equal=4, greater or equal=5 !CODES USED IN OUTPUT FOR 3RD. PASS %constinteger tag def = 1 %constinteger r ref = 2; ! Routine/fn/map/predicate reference %constinteger p ref = 3; ! Prim reference %constinteger sw ref = 4; ! Switch reference %constinteger j ref = 5; ! Jump reference %constinteger c ref = 6; ! Conditional (jump) reference %constinteger code item = 7 %constinteger gla item = 8 %constinteger line flag = 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 block start = 16 %constinteger block end = 17 %constinteger prog end = 18 %constinteger c rel = 19 %constinteger g rel = 20 %constinteger extern = 21 ! (external references) %constinteger data ref = 4, data defn = 5 %constinteger ep ref = 6, ep defn = 7 %recordformat varfm(%integer disp, %c %shortinteger format,extra,length,header, %c (%shortinteger xform %or %byteinteger flag,form), %byteinteger base,type) %record(varfm)%array var(0:max vars) %record(varfm)%name decvar %record(varfm)%name fp, ap %ownrecord(varfm) begin = 0 %recordformat stackfm(%integer disp, %shortinteger format, extra, length, header, rt, %shortinteger var no, type, (%shortinteger xform %or %byteinteger flag,form), (%short xbase %or %byte index, base), %byte dim, oper, %record(stackfm)%name link) %record(stackfm)%array stak(0:max stack) %record(stackfm)%name desc asl %recordformat sptfm(%record(stackfm)%name v) %record(sptfm)%array stacked(1:max depth) ! elements of USING list %recordformat dfm(%record(stackfm)%name d, %record(dfm)%name link) %record(dfm)%array dlist(0:max stack) %record(dfm)%name dasl %record(dfm) using ! for compiling %for/%repeat pairs %recordformat cyclefm(%integer cv disp, fv disp, %c %shortinteger lab, shadow, initial, cv form, %c %byteinteger reg, cv type, cv base, %c fv base, temp base) %record(cyclefm)%array for stk(0:max cycle) %record(cyclefm)%name for; ! points to currently active level %owninteger for stp=0 ! mechanism to minimise no of temporaries allocated %shortintegerarray temps(1:max temps) %owninteger temp base = 0, next temp = 0, new temp = 0 ! list terminator %constrecord(*)%name null == (0) %recordformat labelfm(%shortinteger id, tag) %record(labelfm)%array labels(1:max labels) %ownintegerarray activity(0:fr14) = 0(*) %owninteger claimed = 0 %ownshortinteger control = check bits & (\check extra) %ownshortinteger diagnose = 0 ! 1: trace calls on descriptor stack handling primitives ! 2: . . . . . . . . . LOAD ! 4: . . . . . . . . . ASSIGN ! 8: . . . . . . . optimisation routines and display generated code ! 16: dump 'knowledge' list every time CHEAPEN is called with '8' bit on %owninteger level = -1 %owninteger main ep = 0; ! non-zero if compiling main program %owninteger unassigned rtn = 0; ! non-zero if unassigned check routine pr in %integer j,k,len,n,val,aparm,opr %owninteger ca = 0; ! CODE ADDRESS %owninteger ga = init gla; ! GLA ADDRESS %owninteger lita = 0; ! Literal address: current address %owninteger litmax=0; ! : limit of area claimed so far %owninteger diag1 = 0; ! DIAG TABLES 1 %owninteger diag2 = 0; ! DIAG TABLES 2 %owninteger cc ca=0, cc reg=0; ! to remember condition code %integer sym, next; ! CODE SYMBOL, NEXT SYMBOL %integer vlb,vub; ! VECTOR LOWER/UPPER BOUND %integer Allocate; ! Flag for array(#0) or arrayformat (=0) %integer Falign {alignment of internal formats} %owninteger current line = 0; ! SOURCE LINE NUMBER %owninteger last line = 0 %owninteger stp = 0; ! STACK POINTER %integer data size; ! CURRENT DATA ITEM SIZE %owninteger frame = 0; ! LOCAL STACK FRAME EXTENT %owninteger extra frame = 0; ! ALLOW EXTRA FRAME FOR STATIC ARRAYS %integer parms; ! START OF PARAMETER STACK %integer local; ! LOCAL BASE REGISTER %owninteger invert = 0, swopped = 0; ! CONDITION INVERSION FLAGS %owninteger uncond jump = 0; ! ADDRESS OF CODE HOLE %owninteger gtype = 0; ! 0=RECORDS, 1=PROCEDURE %owninteger gmode = 0; ! NON-ZERO INSIDE PARAMETER LISTS %integer decl; ! LAST-DEFINED DESCRIPTOR %ownshortinteger language mask = 0; ! selects language specific options %integer cheap reg; !Preferred register after ADDRESS %integer otype, owntype, ownform, spec, frozen, potype %integer diag type=0, diag form=0, diag size=0; ! external form/type/size %longreal rvalue !! Initialised to suppress critical unassigned check when compiling itself %owninteger ownval = 0, mantissa = 0; ! *order critical* %integer oarea %integer dim,dv %integer wdisp, pdisp, gdisp %owninteger block no = 0; ! Ordered by block head %owninteger defns=0, specs=0, relocations=0, var diags=0 %owninteger total ca = 0 %owninteger last ca = -1; ! Used by 'set line' %owninteger trace flag = 0; ! controls calling of DUMP TRACE routine %integer jtag; ! Set by 'JUMP TO' %ownstring(ident len) external id = "", alias = "", block name = "" %ownstring(ident len) internal id = "" %owninteger faulty=0 %owninteger null string = 0 %byteintegername cslen %byteintegerarray current string(0:255) ! Register optimisation scratch pad %owninteger Last Gpr = 1, Last Fpr = Fr0, Last EO = 1 %recordformat kfm(%record(kfm)%name link, array, %integer disp, %shortinteger reg, %byteinteger type, form, base, ktype) %record(kfm)%array knowledge(1:max knowledge) %ownrecord(kfm)%name klist == (0), kasl == (0) %integer known regs = 0; ! bit mask: must contain at least ANYF+1 bits %integer in use = 0; !counter to limit active uses !Environment control %recordformat envfm(%integer label, in use, known, %record(kfm)%name link) %record(envfm)%array envir(1:max envirs) %owninteger envp = 0 ! Code generation routine specs %routinespec rr(%integer op,r1,r2) %routinespec rx(%integer op,r1,base,disp) %routinespec rxi(%integer op,r1,base,disp) %routinespec rxd(%integer op,r1,%record(stackfm)%name v) %routinespec set line ! >> SHOW << %routine show(%record(stackfm)%name v) write(v_varno,2); print symbol(':') write(v_type,3); write(v_form,2); write(v_flag,2) write(v_base,3); write(v_disp,5) write(v_length,3) write(v_extra,3); write(v_format,3) write(v_header,3); write(v_dim,3) %if v_oper # 0 %start write(v_oper,2); newline print string(" +") show(v_link) %else newline %finish %end ! >> ABORT << %routine abort(%integer code) %record(dfm)%name dd %integer j select output(report) print string("*Compiler error '") print symbol( (code>>j)&255 ) %for j = 24,-8,0 print string("' at line"); write(current line,1) newline print string("Please seek assistance!!"); newline %if stp # 0 %start print string("STACK:"); newline show(stacked(j)_v) %for j = 1,1,stp %finish %unless using_link == null %start print string("USING:"); newline dd == using_link %cycle show(dd_d) dd == dd_link; %exit %if dd == null %repeat %finish select output(object) %signal 15,15; ! %IF diagnose < 0 %end; ! abort ! >> WARN << %routine warn(%integer n) %switch w(1:8) select output(report) print string("*WARNING: line") write(current line, 1); print string(": ") -> w(n) w(1): print string("division by zero"); -> at w(2): print string("Illegal FOR"); -> at w(3): print string("Non-local control variable?"); -> at w(4): print string("Invalid parameter for READ SYMBOL"); -> at w(5): print string("String constant too long"); -> at w(6): print string("No. of shifts outwith 0..31"); -> at w(7): print string("Illegal constant exponent"); -> at w(8): print string("Numerical constant too big"); -> at at: newline select output(object) %end ! >> MONITOR << %routine monitor(%record(stackfm)%name v, %string(15) text) select output(report) print string(text); print symbol(':') spaces(9-length(text)) show(v) select output(object) %end ! >> FLOATING << %predicate floating(%record(stackfm)%name v) ! check descriptor for floating point quantity %true %if (v_type >= reals %and v_type # 255) %or (v_oper # 0 %c %and v_link_type >= reals) %true %if v_oper >= rexp %false %end ! >> ZERO << %predicate zero(%record(stackfm)%name v) ! CHECK DESCRIPTOR FOR (INTEGER) ZERO %false %if v_disp # 0 %or v_base # 0 %or constant # v_form # AV in S %false %if v_oper # 0 %true %end ! >> CONST << %predicate const(%record(stackfm)%name v) ! CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE %false %unless v_form = constant %and v_oper = 0 %false %if v_type > byte %true %end %integerfn Min Record Size(%record(stackfm)%name A, B) %integer N, M N = A_Format; N = Var(N)_Length&x'FFFF' %if N # 0 M = B_Format; M = Var(M)_Length&x'FFFF' %if M # 0 N = M %if N = 0 %or (M # 0 %and M < N) %result = N %if N > 0 Abort(m'Rec0') %end ! >> SAME << %integerfn POWER(%integer n) %integer j, ref ref = 1 %for j = 1, 1, 14 %cycle ref = ref<<1 %if ref >= n %start %if ref = n %then %result = j %else %result = -1 %finish %repeat %result = -1 %end %predicate same(%record(stackfm)%name v,w) ! Test whether or not V and W describe the same object. %true %if v_disp = w_disp %and v_base = w_base %c %and v_type = w_type %and v_form = w_form %and v_extra = w_extra %false %end ! >> IN FREE REG << %predicate in free reg(%record(stackfm)%name v) ! TRUE if v is in a useable register %false %unless v_form = v in r %and activity(v_base) <= 1 %true %end ! >> TEMP << %integerfn temp ! Allocate a temporary 4 bytes long %integer t %if next temp = new temp %start; ! no spare temps outstanding t = (frame+3)&(\3) frame = t+4 %result = t %if new temp = max temps; ! temp buffer overflow new temp = new temp + 1 temps(new temp) = t %finish next temp = next temp + 1 %result = temps(next temp)&x'FFFF' %end ! >> TAG << %integerfn tag %integer s1, s2 s1 = next readsymbol(s2) readsymbol(next) %result = s1<<8!s2 %end ! >> GET D << %routine get d %longreal p %integer i, n %real ten,one n = 10 ; rvalue = n {initial base} n = 1; one = n n = tag; read symbol(next); ! Skip comma BASE: ten = rvalue rvalue = 0 %cycle sym = next; read symbol(next) %exit %if sym = '.' n = n-1 -> power %if sym = '@' -> base %if sym = '_' sym = sym-'A'+'0'+10 %if sym >= 'A' rvalue = rvalue*ten+(sym-'0') -> SIGN %if n = 0 %repeat p = one %cycle n = n-1; -> SIGN %if n = 0 sym = next; read symbol(next) -> POWER %if sym = '@' sym = sym-'A'+'0'+10 %if sym >= 'A' p = p/ten rvalue = rvalue + (sym-'0')*p %repeat POWER: n = tag n = n ! 16_FFFF0000 %if n&16_8000 # 0 rvalue = rvalue * (ten^n) SIGN: ! sign of whole value %if next = 'U' %start read symbol(next) rvalue = -rvalue %finish %end ! >> RELEASE << %routine release(%integer reg) ! Hazard the value in a register abort(m'REL1') %if reg > fr14 %return %if reg = 0 %or activity(reg) < 0; ! LOCKED activity(reg) = activity(reg)-1 abort(m'REL2') %if activity(reg) < 0 claimed = claimed - 1 %end ! >> CLAIM << %routine claim(%integer reg) ! Cherish the value in a register abort(m'CLM1') %if reg > fr14 %return %if reg = 0 %or activity(reg) < 0 activity(reg) = activity(reg)+1 claimed = claimed+1 %end %routinespec forget reg(%integer mask) %routinespec forget all %routinespec forget var(%record(stackfm)%name v) ! >> HAZARD << %routine hazard(%integer reg) ! Protect the value in register REG by storing in a temporary. %integer n, t, tot %record(dfm)%name p %record(stackfm) u %routine mod(%record(stackfm)%name v) %switch sw(0:a in rec) v_base = local n = n-1 -> sw(v_form) sw(a in rec): sw(av in rec): sw(v in rec): %if tot = 1 %start claim(reg); rx(lw,reg,reg,v_extra) u_type = integers v_extra = t -> OUT2 %finish sw(constant): abort(m'HAZ1') sw(v in s): %if v_disp = 0 %start v_disp = t; v_form = a in s; ->out1 %finish sw(a in s): sw(av in s): ! change (X in S) to (X in REC) v_form = v_form + 3; v_extra = t; -> OUT1 sw(v in r): v_form = v in s; v_disp = t v_type = u_type OUT1: v_flag = v_flag ! assigned OUT2: %end n = activity(reg); %return %if n <= 0; ! NOT IN USE OR CLAIMED tot = n claimed = claimed - n activity(reg) = 0 t = temp; ! ** needs a parameter to deal with 8-byte reals ** u_type = integers u_type = reals %if FR0 <= reg <= FR14 p == using_link %cycle %exit %if p == null mod(p_d) %if p_d_base = reg p == p_link %repeat u_xbase = local; u_disp = t u_xform = V in S ! (assigned << 8) rxd(st,reg,u) forget var(u) abort(m'HAZ2') %if n # 0; ! USE STILL OUTSTANDING %end ! >> HAZARD ALL << %routine hazard all %integer j forget reg(-1) %if claimed # 0 %start; ! at least one register claimed hazard(j) %for j = r0,1,fr14 %finish %end ! REGISTER OPTIMISATION ROUTINES %constinteger register contents = 1 %routine Reset Optimisation Data %integer J Last Gpr = 1 Last Fpr = Fr0 Last EO = 1 Envp = 0 Known Regs = -1 In Use = 0 Kasl == Null Klist == Null %for j = 1,1,max knowledge %cycle knowledge(j)_Link == Kasl Kasl == knowledge(j) %repeat %for j = 1,1,max envirs %cycle Envir(j)_Label = 0 Envir(j)_Link == Null %repeat %end ! >> DUMP OPT LIST << %routine dump opt list %record(kfm)%name p select output(report) p == klist %if p == null %start print string("*opt list empty") newline %else %cycle write(p_type,1); write(p_form,1) write(p_disp,3); print symbol('(') write(p_base,-1); print string(") =") write(p_reg,1); newline p == p_link %repeat %until p == null %finish select output(object) %end; ! dump opt list ! >> K ENTRY << %record(kfm)%map k entry(%record(stackfm)%name v, %integer fuzz) %record(kfm)%name p,q fuzz = \fuzz p == k list q == null %while %not p == null %cycle -> FOUND %if (p_disp!!v_disp)&fuzz = 0 %and p_base = v_base q == p p == p_link %repeat %result == null; ! failure FOUND: %if %not q == null %start; ! promote if not first item already q_link == p_link p_link == klist klist == p %finish %result == klist %end; ! k entry ! >> NEW KCELL << %record(kfm)%map new kcell %record(kfm)%name p, q %integer n %if kasl == null %or in use >= max use %start; ! no free cells left ! In extremis so reclaim last item from KLIST. p == klist; q == null n = max use %cycle n = n-1 %exit %if p_link == null q == p p == p_link %repeat abort(m'OPT1') %if n # 0 q_link == null; ! truncate KLIST p_link == kasl; kasl == p; !give on back in use = in use-1 %finish p == kasl; kasl == kasl_link in use = in use+1; abort(m'Opt3') %if in use > max use p = 0 %result == p %end; ! new kcell ! >> ASSOCIATE << %routine associate(%record(stackfm)%name v, %integer reg) %record(kfm)%name p %return %if reg = R0 %or V_Base = Reg p == k entry(v,0) %if p == null %start; ! new entry p == new kcell p_link == klist klist == p %else; ! re-use this cell forget reg(1<= 0; ! unlocked ? %end; ! associate ! >> CHEAPEN << %routine cheapen(%record(stackfm)%name v, %integer mode) !! modes: >= 0: looking for value ! < 1: looking for address %record(kfm)%name p %integer reg, form, type form = v_form; type = v_type p == k entry(v,0) %return %if p == null v_flag = v_flag ! assigned %if p_form = V in S; ! it's at least assigned %return %if p_reg = 0; !*psr* Nothing known cheap reg = p_reg %if form # AinS %and p_type = Type %return %if mode < 0 %and form = V in S; ! V in S on left-hand side reg = p_reg %if form = A in S %and p_type = integers %and p_form = V in S %start release(v_base); claim(reg) v_base = reg; v_disp = 0; v_Xform = V in S {changed to Xform - PSR} cheapen(v,mode) %else %return %if p_type # type %or p_form # form release(v_base); claim(reg) v_base = reg; v_disp = 0; v_Xform = V in R {changed to Xform - PSR} %finish %if diagnose < 0 %start monitor(v, "CHEAPENED") dump opt list %if diagnose & 16 # 0 %finish %end; ! cheapen !!! * * * * * This needs to be a bit brighter * * * * * ! >> FORGET VAR << %routine forget var(%record(stackfm)%name v) %record(kfm)%name p !!!!! p == k entry(v, align) !!!!! forget reg(1<> FORGET REG << %routine forget reg(%integer reg mask) %record(kfm)%name p %return %if known regs & reg mask = 0; ! for speed: nothing to do reg mask = reg mask & (\1); ! R0 = 1 not 0 known regs = known regs & (\reg mask) p == klist %if reg mask < 0 %start; ! forget the lot %while %not p == null %cycle p_base = anyf+1 %if regmask & (1<> FORGET ALL << %routine forget all %record(kfm)%name p %if %not klist == null %start p == klist %cycle in use = in use-1 %exit %if p_link == null p == p_link %repeat p_link == kasl kasl == klist klist == null %finish abort(m'Fall') %unless in use = 0 known regs = 0 %end; ! forget all !environment control %record(envfm)%map environment(%integer label) %record(envfm)%name E %integer j %if label > 0 %start %for j = 1,1,max envirs %cycle E == envir(j) %result == E %if E_label = label %repeat %finish %result == null %end %record(envfm)%map new env(%record(envfm)%name E) %record(kfm)%name K %if E == null %start envp = envp+1; envp = 1 %if envp > max envirs e == envir(envp) %finish k == E_link %unless k == null %start k == k_link %while k_link ## null k_link == kasl kasl == E_link %finish E_in use = 0 E_label = 0 E_link == null %result == E %end %record(kfm)%map Ecopy(%record(kfm)%name L) %record(kfm)%name K %result == null %if l == null abort(m'Ecop') %if kasl == null k == kasl; kasl == k_link k = l k_link == Ecopy(l_link) %result == k %end %routine restore environment(%integer label) %record(envfm)%name E %record(envfm) temp temp_link == klist e == new env(temp) {release current environment} E == environment(label) %if E == null %start klist == null known regs = 0 in use = 0 %else klist == Ecopy(E_link) known regs = E_known in use = E_in use %finish %end %routine remember environment(%integer label) %record(envfm)%name E %return %if label <= 0 E == environment(label) E == new env(E) E_label = label E_known = known regs E_in use = in use E_link == Ecopy(klist) %end %routine merge environment(%integer label) %record(ENVFM)%name e %record(kfm)%name K, end, X %record(kfm) khead %routine MERGE(%record(kfm)%name K) %record(kfm)%name p p == klist %while p ## null %cycle %if p_disp = k_disp %and p_reg = k_reg %and p_base = k_base %and p_form = k_form %and p_type = k_type %and p_ktype= k_ktype %start {*****Beware when array opt is put in***} end_link == k end == k E_known = E_known ! (1<> GPR << %integerfn gpr ! Get a general (integer) register %constinteger nregs=8 %constbyteintegerarray pref(1:nregs) = P1, P2, R4, R9, R10, R11, R3, R12 %integer r,j,mask mask = known regs %cycle %for j = 1,1,nregs %cycle Last Gpr = Last Gpr-1; Last Gpr = nregs %if Last Gpr = 0 r = pref(Last Gpr) %result = r %if activity(r) = 0 %and mask & (1<> EVEN/ODD PAIR << %integerfn even odd pair ! Get an even/odd (integer) register pair ! the odd register is returned ! registers are hazarded here %constinteger regs = 3 %constbyteintegerarray even(1:regs) = r2, r10, r4 %integer j,r,mask mask = known regs %cycle %for j = 1,1,regs %cycle Last EO = Last EO-1; Last EO = regs %if Last EO = 0 r = even(Last EO) %result = r+1 %if activity(r) = 0 %and activity(r+1) = 0 %c %and mask & (3<> FPR << %integerfn fpr ! get a floating point register %integer j,mask mask = known regs %cycle %for j = fr0,1,fr14 %cycle Last Fpr = Last Fpr-1; Last Fpr = fr14 %if Last Fpr = fr0-1 %result = Last Fpr %if activity(Last Fpr) = 0 %repeat %exit %if mask = 0 mask = 0 %repeat hazard(fr0) %result = fr0 %end !OBJECT FILE HANDLING ROUTINES ! >> PUT << %routine put(%integer n) print symbol(n>>8); print symbol(n&255) %end ! >> SELECT LITERAL AREA << %routine select literal area %integer k print symbol(lit area) abort(m'DMP1') %if ca < 0 k = lita; lita = ca; ca = k %end ! >> SELECT CODE AREA << %routine select code area %integer k abort(m'DMP2') %if ca > 0 k = lita; lita = ca; ca = k print symbol(code area) %end %routine phex(%integer n) %integer j,k spaces(2) %for j = 12,-4,0 %cycle k = (n>>j)&15 %if k <= 9 %then k = k+'0' %else k = k-10+'A' print symbol(k) %repeat %end ! >> DUMP TAG << %routine dump tag(%integer tag, type) %conststring(7)%array s(tag def:c ref) = " defn", " r ref", " p ref", " sw ref", " j ref", " c ref" select output(report) print symbol('*'); write(ca,-3) print string(s(type)) write(tag,1) newline select output(object) %end; ! dump tag ! >> DUMP << %routine dump(%integer p,val) %integer k select output(report) %if p = m'CA' %start print string("CA "); k = ca %else print string("GA "); k = ga %finish write(k-2,-3); print symbol(':') phex(val) newline select output(object) %end; ! dump ! >> CPUT << %routine cput(%integer n) ! Output one halfword to code area print symbol(code item) print symbol(n>>8); print symbol(n&255) ca = ca+2 dump(m'CA',n) %if diagnose < 0 %end ! >> GPUT << %routine gput(%integer n) ! Output one halfword to gla area print symbol(gla item) print symbol(n>>8); print symbol(n&255) ga = ga+2 dump(m'GA',n) %if diagnose < 0 %end ! >> CWORD << %routine cword(%integer n) cput(n>>16); cput(n) %end ! >> LIT BYTE << %routine lit byte(%integer n) %owninteger v=0,f=0 f = \f %if f=0 %start ca = ca+1; cput(v<<8 + n&255) %else v = n; ca = ca-1 %finish abort(m'DMP3') %unless ca <= 0 %end ! >> GWORD << %routine gword(%integer n) gput(n>>16); gput(n&x'FFFF') %end ! >> GWORD REL << %routine gword rel(%integer n) ! Word in GLA modified at load-time by gla base address - used to relocate ! %ownarray headers. gput(n>>16); gput(n&x'FFFF') print symbol(g rel); relocations = relocations + 1 %end; ! gword rel ! >> GWORD CREL << %routine gword crel(%integer n) ! Word in GLA modified at load-time by code base address - used to relocate ! %constarray headers gput(n>>16); gput(n&x'FFFF') print symbol(c rel); relocations = relocations+1 %end; ! GWORD CREL ! >> GBYTE << %routine gbyte(%integer n) %owninteger v=0, f=0 f = \f %if f = 0 %start ga = ga-1; gput(v<<8 + n&255) %else v = n; ga = ga+1 %finish %end ! >> GFIX << %routine gfix(%integer align) gbyte(0) %while ga&align # 0 %end ! >> DEFINE TAG << %routine define tag(%integer ref) %integer k select output(direct) print symbol(tag def) print symbol(ref>>8); print symbol(ref&255) k = ca>>1; ! ******* Halfword units print symbol(k>>8); print symbol(k&255) select output(object) dump tag(ref,tag def) %if diagnose < 0 %end; ! define tag ! >> DEFINE REFERENCE << %routine define reference(%integer ref, type) %integer k set line %if current line # last line select output(direct) print symbol(type) print symbol(ref>>8); print symbol(ref&255) k = ca>>1; ! ******** Halfword units print symbol(k>>8); print symbol(k&255) select output(object) dump tag(ref,type) %if diagnose < 0 print symbol(type) %if type = r ref %start print symbol(ref>>8); print symbol(ref&255) %finish %end; ! define reference ! >> CLAIM LITERAL << %routine claim literal(%integer size,align) %integer k abort(m'DMP4') %if ca < 0 %or litmax > 0 %if lita&1 # 0 %start; ! odd no. of bytes select literal area lit byte(0) select code area %finish litmax = -((-litmax+size+align)&(\align)) lita = litmax k = (-lita)>>1 print symbol(lit org); put(k); ! Tell pass 3 %end; ! claim literal ! >> SET LINE << %routine set line %integer flag %return %if ca < 0; !in literal area %if current line-last line # 1 %then flag = line reset %c %else flag = line flag select output(direct) print symbol(flag); put(current line) %if flag = line reset %if diagnose < 0 %start select output(report) print string("-->line"); write(current line,1) newline %finish select output(object) print symbol(flag); put(current line) %if flag = line reset last line = current line; last ca = ca %end; ! set line ! >> DESCRIBE << %routine describe(%integer base,disp, %string(ident len)%name xsym) ! Generate a full description of the variable specified by (base,disp) ! Assumes that DIAG SIZE, DIAG TYPE, DIAG FORM, OTYPE are appropriately set. %integer size,type %integer j,k %constbyteintegerarray compressed type(0:13) = 1, 2, 3, 4, 5, 0(3), 6, 0(4), 7 ! integer real string record byte short long real length(xsym) = extern len %if length(xsym) > extern len print symbol(length(xsym)) print symbol(charno(xsym,j)) %for j = 1,1,length(xsym); ! name %return %if base < 0 size = diag size; type = diag type size = 1 %if diag type >= 3 %or diag form > 2 %or size = 0 type = 1 %if diag type <= 0 k = (size-1) << 2 + (type-1) j = 0 j = x'80' %if Otype # 0 %and Spec # 0 {external data spec} print symbol(otype) print symbol( compressed type(k) << 4 ! DIAG FORM ! J) j = actual(base)<<20 + disp&x'000FFFFF' print symbol(j>>16); print symbol(j>>8); print symbol(j) %end; ! describe ! >> SET DIAG << %routine set diag(%integer base,disp) ! Implicit parameters: DIAG TYPE DIAG FORM DIAG SIZE OTYPE var diags = var diags + basic vdiag var diags = var diags + extra vdiag %if length(internal id) > short ident print symbol(var diag); describe(base,disp,internal id) %end ! >> EXTERNAL LINK << %routine external link(%integer ref type,data size,addr) !Note that ADDR is ignored when defining procedure entry points ! it is assumed that the link is set IMMEDIATELY before the entry point. %integer k abort(m'DMP5') %unless data ref <= ref type <= ep defn %if ref type&1 # 0 %then defns = defns+1 %else specs = specs+1 print symbol(extern) print symbol(ref type) put(data size//2); ! Halfwords for pass3 k = gla; k = code %if ref type = ep defn describe(k,addr//2,external id) %if ref type&1 = 0 %start; !a spec gword(0); gword(0) %if ref type = ep ref %then gword(0) %else gword(-1) %finish %end ! >> CLOSE FILES << %routine close files select output(direct) print symbol(prog end) put(total ca>>1); put((-litmax)>>1); put(ga>>1); ! Halfword units put(defns); put(specs); put(relocations) print symbol(0); ! to prevent potential trouble with binary 4 = EOF close output select output(object); print symbol(prog end) close output %end; ! close files ! code generation routines ! >> RXD << ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! B a s i c C o d e G e n e r a t o r ! %routine RXD(%integer op, r1, %record(stackfm)%name v) %integer index, mask, code, format %integer type, form, base, disp, x %integer k, old ca %record(stackfm) u %constbyteintegerarray type index(integers:reals+1) = 1, 2, 7, 0(3), 1, 0 ! integer short byte reals reall old ca = ca type = v_type; form = v_form base = v_base; disp = v_disp; x = v_index op = op + fp base %if r1 >= FR0 mask = op index(op); index = mask&255 set line %if last line # current line %if form = constant %or form = AV in S %start; ! RXI abort(m'RXDx') %if x # 0 %if disp = 0 %and base # 0 %and LSH # op # RSH %and op # SRA %start ! optimise: LHI x,0(y) => LR x,y ! remove: LHI x,0(x) %if r1 # base %or op # LW %start u_xbase = base; u_disp = 0; ! **** u_disp otherwise unassigned **** u_form = V in R; rxd(op,r1,u) %return %finish code = x'10'; !(psr) preserve CC at end - see later %else %if op = LW %and r1 = base %and 15 >= disp >= -15 ! LHI x, 15(x) => AIS x,15 ! LHI x,-15(x) => SIS x,15 op = add %if disp < 0 %start op = sub; disp = -disp %finish u_form = constant; u_xbase = 0; u_disp = disp; rxd(op,r1,u) release(base) %return %else %if op = LSH %and disp = 1 %and base = 0 ! SLLS x,1 => AR x,x claim(r1) u_xbase = r1; u_disp = 0 u_form = V in R; rxd(add,r1,u); %return %else; ! general case (RXI) abort(m'RXD1') %if mask&FWIMM = 0 %and LSH # op # RSH %and op # SRA index = index + 3; ! fullword immediate format = 0 %if 15>=disp>=-15 %and base=0 %and (SF IMM+INV IMM)&mask # 0 %start %if disp >= 0 %start format = 2 %else format = 3; disp = -disp %finish %else %if 32767 >= disp >= -32768 format = 1 %finish code = op code(index + format) %if format >= 2 %start cput(code&x'FF00' + actual(r1)<<4 + disp) %else cput(code&x'FF00' + actual(r1)<<4 + actual(base)) cput(disp>>16) %if format = 0; ! fullword immediate ? cput(disp) %finish %finish %else %if form = V in R; ! register-register operation abort(m'RXD2') %if r1 = 0 %or base = 0 %or x # 0 code = op code(index); ! ** N.B. op code(index + 0) really ...... %if code&x'20' # 0 %start; ! STR => LR etc. k = r1; r1 = base; base = k %finish cput(code&x'FF00' + actual(r1)<<4 + actual(base)) %else; ! RX (integer,real,short,byte) abort(m'RXD3') %if r1 = 0 %or base = R0 format = type index(type); abort(m'RXD4') %if format = 0 code = op code(index + format) abort(m'RXD5') %if (code&15)&disp # 0 cput(code&x'FF00' + actual(r1)<<4 + actual(base)) %unless 0 <= disp <= 16383 %and x = 0 %start cput(x'4000' + actual(x)<<8 + (disp>>16)&255) %finish cput(disp) %finish release(base) %if base > 0; !(PSR) release(x) %if x # 0 %if code&x'40' # 0 %start; ! leaves cond code completely unchanged cc ca = cc ca + ca - old ca %else %if code&x'10' = 0; ! cond code relative to zero ? cc ca = ca; cc reg = r1 %finish %end; ! of 'RXD' ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! >> RR << %routine rr(%integer op,r1,r2) %record(stackfm) v v_xbase = r2; v_disp = 0 v_type = integers; v_type = reals %if r1 >= FR0 v_form = V in R; rxd(op, r1, v) %end ! >> RXI << %routine rxi(%integer op, r1, base, disp) %record(stackfm) v v_xbase = base; v_disp = disp v_type = integers v_form = constant; rxd(op, r1, v) %end ! >> RX << %routine rx(%integer op, r1, base, disp) %record(stackfm) v v_xbase = base; v_disp = disp v_type = integers; v_type = reals %if r1 >= FR0 v_form = V in S; rxd(op, r1, v) %end ! >> SKIP << %routine skip(%integer half words, condition) ! Plant a short forward jump to skip over unwanted code sequence: ! skips forward the number of halfwords specified NOT COUNTING the ! code dumped to effect the skip ! Must be used with care as it doesn't account automatically for register ! contents. %constshortintegerarray jump(0:5) = x'2330', x'2130', x'2110', x'2120', x'2320', x'2310' ! BES BNES BMS BPS BNPS BNMS Condition = Inverted(Condition) %if Condition&16 # 0 abort(m'SKP1') %unless 0 < halfwords <= 14 %and 0 <= condition <= 5 cput( jump(condition) ! (halfwords + 1) ) %end ! >> MACHINE CODE << %routine machine code %constinteger branch = 1 %constinteger rr = 2 %constinteger indexed = 4 %constinteger ri1 = 8 %constinteger ri2 = 16 !*delete* %constinteger mc entries = 204 %constintegerarray mcop(1:mc entries) = x'00000041', x'00000042', x'00000043', x'00000044', x'0000004C', ! A B C D L x'0000004D', x'0000004E', x'0000004F', x'00000053', x'00000058', ! M N O S X x'00001004', x'00001005', x'00001008', x'00001009', x'0000100C', ! AD AE AH AI AL x'0000100D', x'00001012', x'00001084', x'00001085', x'00001088', ! AM AR CD CE CH x'00001089', x'0000108C', x'00001092', x'000010C3', x'000010C5', ! CI CL CR BC BE x'000010C7', x'000010CC', x'000010CD', x'000010CF', x'000010D0', ! BG BL BM BO BP x'000010D2', x'000010DA', x'00001144', x'00001145', x'00001148', ! BR BZ DD DE DH x'00001152', x'00001304', x'00001305', x'00001308', x'00001312', ! DR MD ME MH MR x'00001341', x'00001342', x'00001344', x'00001345', x'00001348', ! LA LB LD LE LH x'00001349', x'0000134D', x'00001352', x'00001383', x'00001388', ! LI LM LR OC OH x'00001389', x'00001392', x'000013C8', x'000013C9', x'000013D2', ! OI OR NH NI NR x'00001484', x'00001485', x'00001488', x'00001489', x'00001492', ! SD SE SH SI SR x'00001493', x'00001494', x'000014C2', x'000014C4', x'000014C8', ! SS ST RB RD RH x'00001549', x'00001553', x'00001582', x'00001584', x'00001588', ! TI TS WB WD WH x'00001648', x'00001649', x'00001652', x'000400CC', x'00040112', ! XH XI XR ABL AER x'00040152', x'00040213', x'00040249', x'0004024D', x'0004054C', ! ADR AIS AHI AHM ATL x'000420D4', x'00042112', x'00042152', x'00042249', x'00042342', ! CBT CER CDR CHI CLB x'00042348', x'00042349', x'00042352', x'0004300C', x'00043092', ! CLH CLI CLR BAL BCR x'00043112', x'00043185', x'00043192', x'000431C3', x'00043312', ! BER BGE BGR BFC BMR x'00043345', x'00043352', x'00043392', x'000433C3', x'000433C5', ! BLE BLR BOR BNC BNE x'000433CC', x'000433CD', x'000433CF', x'000433D0', x'000433DA', ! BNL BNM BNO BNP BNZ x'00043452', x'00043543', x'00043648', x'000436D2', x'00045112', ! BPR BTC BXH BZR DER x'00045152', x'00045252', x'00047352', x'00047652', x'0004C112', ! DDR DHR FLR FXR MER x'0004C152', x'0004C252', x'0004D093', x'0004D0D2', x'0004D112', ! MDR MHR LCS LBR LER x'0004D152', x'0004D213', x'0004D249', x'0004D24C', x'0004D304', ! LDR LIS LHI LHL LMD x'0004D305', x'0004E092', x'0004E249', x'0004F249', x'0004F390', ! LME OCR OHI NHI NOP x'00052090', x'000520D4', x'00052112', x'00052152', x'00052213', ! SCP SBT SER SDR SIS x'00052249', x'00052341', x'00052492', x'000524C1', x'000524CC', ! SHI SLA SSR SRA SRL x'000524D2', x'00052542', x'00052544', x'00052545', x'00052548', ! SRR STB STD STE STH x'0005254D', x'000525C3', x'000530CC', x'000530D2', x'000530D4', ! STM SVC RBL RBR RBT x'00053152', x'00053252', x'0005334C', x'000534CC', x'0005354C', ! RDR RHR RLL RRL RTL x'000550D4', x'00055249', x'000560D2', x'00056152', x'00056252', ! TBT THI WBR WDR WHR x'00059249', x'010895D2', x'0108D249', x'010C0352', x'010C6112', ! XHI CHVR CLHI BALR BGER x'010C7092', x'010C7092', x'010C70D3', x'010C71D3', x'010CD112', ! BFCR BFCR BFBS BFFS BLER x'010CF092', x'010CF112', x'010CF312', x'010CF352', x'010CF392', ! BNCR BNER BNMR BNLR BNOR x'010CF452', x'010CF6D2', x'010D5092', x'010D50D3', x'010D51D3', ! BNPR BNZR BTCR BTBS BTFS x'010D9345', x'01111492', x'011190D2', x'01119252', x'011CD152', ! BXLE EPSR EXBR EXHR FLDR x'011D9152', x'01351497', x'013CE452', x'014883D4', x'0148D241', ! FXDR LPSW NOPR SINT SLHA x'0148D24C', x'0148D353', x'01493241', x'0149324C', x'01493353', ! SLHL SLLS SRHA SRHL SRLS x'014950D2', x'01495304', x'01495305', x'424C3C72', x'424C3C76', ! STBR STMD STME CRC12 CRC16 x'4D452592', x'52349353', x'524C9353', x'55340545' ! LPSWR SLHLS SRHLS TLATE %constshortintegerarray opflags(1:mc entries) = x'5A04', x'4305', x'5904', x'5D04', x'5804', x'5C04', x'5404', x'5604', ! A B C D L M N O x'5B04', x'5704', x'7A04', x'6A04', x'4A04', x'FA10', x'D501', x'5104', ! S X AD AE AH AI AL AM x'0A02', x'7904', x'6904', x'4904', x'F910', x'5504', x'0902', x'4285', ! AR CD CE CH CI CL CR BC x'4335', x'4225', x'4285', x'4215', x'4245', x'4225', x'0303', x'4335', ! BE BG BL BM BO BP BR BZ x'7D04', x'6D04', x'4D04', x'1D02', x'7C04', x'6C04', x'4C04', x'1C02', ! DD DE DH DR MD ME MH MR x'E604', x'D304', x'7804', x'6804', x'4804', x'F810', x'D104', x'0802', ! LA LB LD LE LH LI LM LR x'DE04', x'4604', x'F610', x'0602', x'4404', x'F410', x'0402', x'7B04', ! OC OH OI OR NH NI NR SD x'6B04', x'4B04', x'FB10', x'0B02', x'DD04', x'5004', x'D704', x'DB04', ! SE SH SI SR SS ST RB RD x'D904', x'F310', x'E004', x'D604', x'DA04', x'D804', x'4704', x'F710', ! RH TI TS WB WD WH XH XI x'0702', x'6504', x'2A02', x'3A02', x'2602', x'CA08', x'6104', x'6404', ! XR ABL AER ADR AIS AHI AHM ATL x'7704', x'2902', x'3902', x'C908', x'D404', x'4504', x'F510', x'0502', ! CBT CER CDR CHI CLB CLH CLI CLR x'4104', x'0281', x'0333', x'4315', x'0223', x'4304', x'0213', x'4325', ! BAL BCR BER BGE BGR BFC BMR BLE x'0283', x'0243', x'4385', x'4235', x'4385', x'4315', x'4345', x'4325', ! BLR BOR BNC BNE BNL BNM BNO BNP x'4235', x'0223', x'4204', x'C004', x'0333', x'2D02', x'3D02', x'0D02', ! BNZ BPR BTC BXH BZR DER DDR DHR x'2F02', x'2E02', x'2C02', x'3C02', x'0C02', x'2502', x'9302', x'2802', ! FLR FXR MER MDR MHR LCS LBR LER x'3802', x'2402', x'C808', x'7304', x'7F04', x'7204', x'9E02', x'C608', ! LDR LIS LHI LHL LMD LME OCR OHI x'C408', x'4205', x'E304', x'7504', x'2B02', x'3B02', x'2702', x'CB08', ! NHI NOP SCP SBT SER SDR SIS SHI x'EF00', x'9D02', x'EE00', x'EC00', x'ED00', x'D204', x'7004', x'6004', ! SLA SSR SRA SRL SRR STB STD STE x'4004', x'D004', x'E104', x'6704', x'9702', x'7604', x'9B02', x'9902', ! STH STM SVC RBL RBR RBT RDR RHR x'EB00', x'EA00', x'6604', x'7404', x'C308', x'9602', x'9A02', x'9802', ! RLL RRL RTL TBT THI WBR WDR WHR x'C708', x'1202', x'C508', x'0102', x'0313', x'0302', x'1302', x'2202', ! XHI CHVR CLHI BALR BGER BFCR BFCR BFBS x'2302', x'0323', x'0383', x'0233', x'0313', x'0383', x'0343', x'0323', ! BFFS BLER BNCR BNER BNMR BNLR BNOR BNPR x'0233', x'0202', x'2002', x'2102', x'C104', x'9502', x'9402', x'3402', ! BNZR BTCR BTBS BTFS BXLE EPSR EXBR EXHR x'3F02', x'3E02', x'C205', x'0203', x'E201', x'CF08', x'CD08', x'1102', ! FLDR FXDR LPSW NOPR SINT SLHA SLHL SLLS x'CE08', x'CC08', x'1002', x'9202', x'7E04', x'7104', x'5E04', x'5F04', ! SRHA SRHL SRLS STBR STMD STME CRC12 CRC16 x'1801', x'9102', x'9002', x'E704' ! LPSWR SLHLS SRHLS TLATE !*end* %string(7) opcode %record(varfm)%name v %integer op, base, disp, index, flags, p, n, reg %routine mc error(%string(255) s) selectoutput(0) printsymbol('*') write(current line, 3) space printstring(opcode) printstring(": ") printstring(s) newline selectoutput(object) %while sym # ';' %cycle sym = next; readsymbol(next) %repeat %end %routine get opcode opcode = ""; op = 0 %cycle sym = next; readsymbol(next) %exit %if sym = '_' %if length(opcode) # 6 %start op = op<<6!!sym opcode = opcode.tostring(sym) %finish %repeat sym = next; readsymbol(next) %end %integerfn find opcode %integer high, low, p high = mc entries; low = 1 %while high >= low %cycle p = (high+low)>>1 %result = p %if mcop(p) = op %if mcop(p) > op %then high = p-1 %else low = p+1 %repeat mc error("unknown operation") %result = 0 %end %predicate value(%integername n) n = 0 %false %unless '0' <= sym <= '7' %cycle n = n<<3!(sym-'0') sym = next; readsymbol(next) %true %unless '0' <= sym <= '7' %repeat %end %predicate register(%integername r) %false %unless value(r) %false %unless 0 <= r <= 15 %true %end %predicate deal with plus minus %integer sign, n %true %unless sym = '+' %or sym = '-' sign = sym; sym = next; readsymbol(next) %unless value(n) %start mc error("invalid offset") %false %finish n = -n %if sign = '-' disp = disp+n %true %end base = -1; index = -1; disp = 0 get opcode p = find opcode; %return %if p = 0 flags = opflags(p) %if flags&branch # 0 %start reg = flags>>4&15; !cond-code %else %unless register(reg) mc error("register 1?"); %return %else %if sym # ',' mc error("comma missing"); %return %else sym = next; readsymbol(next) %finish %if flags&rr # 0 %start %unless register(base) %start mc error("register 2?"); %return %finish %else %if sym = ' '; !named operand n = tag sym = next; readsymbol(next) v == var(n) disp = v_disp %if v_form = pgm label %start; !%label define reference(disp&X'FFF', r ref); !make it look like a routine disp = 0; Base = Code %return %unless deal with plus minus %else base = actual(v_base) %unless v_base = 0 %return %unless deal with plus minus %if sym = '(' %start ->ix %if base > 0 ->ib %finish %finish %else %if sym = '-' %and deal with plus minus %start !only needs the side-effect of deal with .. %else %unless value(disp) mc error("displacement?"); %return %finish %return %unless deal with plus minus %if sym = '(' %start ib: sym = next; readsymbol(next) %unless register(base) %start mc error("base register?"); %return %finish %if sym = ',' %start ix: sym = next; readsymbol(next) %if flags&indexed = 0 %start mc error("no double indexed form"); %return %finish %unless register(index) %start mc error("index register?"); %return %finish %finish %if sym # ')' %start mc error(") missing"); %return %finish sym = next; readsymbol(next) %finish %finish %if sym # ';' %start mc error("form?"); %return %finish base = 0 %if base < 0 index = 0 %if index < 0 base = index %and index = 0 %if base = 0 %and index # 0 cput(flags&x'FF00'+reg<<4+base) %if flags&ri1 # 0 %start cput(disp&x'FFFF') %else %if flags&ri2 # 0 %and flags&branch = 0 cput(disp>>16); cput(disp&x'FFFF') %else %if flags&rr = 0 %if disp>>14 # 0 %or index > 0 %start mc error("no RX3 form") %and %return %if flags&indexed = 0 cput(x'4000'+index<<8+disp>>16&x'FF') %finish cput(disp&x'FFFF') %finish %end ! >> SET DOPE VECTOR << %routine set dope vector %integer t t = vub-vlb+1 claim literal(4*reglen,3) select literal area dv = ca cword(1) cword(vlb); cword(vub) cword(data size) select code area vub = t*data size; vlb = vlb*data size %end ! >> PERM << %routine perm(%integer n) %constinteger g0=1, g1=2, g2=4, g3=8, g4=16, g5=32, g6=64; ! General Registers %constinteger f0=128, f2=256; ! Floating Registers %constinteger prot = (-1)<<15; ! protect stack around call %constshortintegerarray rmap(0:8) = R0, R1, R2, R3, R4, P2, P1, FR0, FR2 %integer k,r,h ! ! **** N.B. The following table must match the properties of the perm ! routines in use. %constinteger perm routines = 50 %constshortintegerarray hazard reg(1:perm routines) = 0, ; ! 1: ASSCHK G0+G3, ; ! 2: IEXP G0+F0+F2, ; ! 3: REXP G0+G3+G4, ; ! 4: SMOVE G0+G3+G5, ; ! 4: SJAM G0+G1+G2+G3+G4+G5, ; ! 6: SCONC G0+G5+G6, ; ! 7: SRESLN 0, ; ! 8: SRESV G0+G3+G4+G5, ; ! 9: SCOMP F0+F2, ; ! 10: FRAC PT 0, ; ! 11: SFCAP G0+G1+G2+G3+prot, ; ! 12: SUBSTR G0+G1+G2, ; ! 13: AREF1 G0+G1+G4, ; ! 14: AREF2 G0+G1+G4+G5, ; ! 15: AREF3 G0+G1+G4, ; ! 16: AREF4 G0+G1+G2+G3, ; ! 17: SETDV G0+G5, ; ! 18: ALLOC 0, ; ! 19: SWJMP 0, ; ! 20: SIGNAL 0, ; ! 21: MULCHK 0, ; ! 22: CAP16 0, ; ! 23: CAP8 G0+G1, ; ! 24: FCHK1 0, ; ! 25: FCHK2 G2+G3+G4, ; ! 26: PENTC G0+G3, ; ! 27: RCOPY G0+G3, ; ! 28: RZERO 0, ; ! 29: VSCHK G0+G3+G4, ; ! 30: SMOVOPT G0+G1, ; ! 31: CHMAP G1, ; ! 32: FREESP G1+F2, ; ! 33: INT G0+G3+G4+G5, ; ! 34: RECORD COMPARE G0+G1+G2+G3+G4+G5+G6, ; ! 35: SET COMPARE G0+G3, ; ! 36: SET UNION G0+G3, ; ! 37: SET DIFFERENCE G0+G3, ; ! 38: SET INTERSECTION 0, ; ! 39: 0, ; ! 40: 0, ; ! 41: 0, ; ! 42: 0, ; ! 43: 0, ; ! 44: 0, ; ! 45: 0, ; ! 46: 0, ; ! 47: 0, ; ! 48: G0+G1+G2+G3+G4+G5+G6+F0+F2, ; ! 49: IOCP G0+G1+G2+G3+G4+G5+G6+F0+F2 ; ! 50: ENTER TRACE h = hazard reg(n); ! property mask for nth. perm routine %if claimed # 0 %start; ! maybe something to do .. perhaps k = h&x'7FFF'; ! register mask r = 0 %while k # 0 %cycle hazard(rmap(r)) %if k&1 # 0 k = k>>1 r = r+1 %repeat %finish ! forget all registers which are at risk r = ( ((h&(F0+F2)) << (FR0-P1)) ! (h&127) ) << 1; ! ** N.B. P1 == G6 forget reg(r) rxi(ADD,wsp,0,wdisp) %if h < 0 %and wdisp # 0 define reference(n&255,p ref) rx(bal,link,code,n&255) %if h < 0 %start rxi(SUB,wsp,0,wdisp) %if wdisp # 0 wdisp = wdisp + basic frame + 256; ! protect it %finish %end ! >> DUMP TRACE << %routine DUMP TRACE %if current line # last line %start trace flag = 0 perm(enter trace); cput(current line) %finish %end ! >> ASSEMBLE << ! AMODE: ! -2: alternate record format ! -1: record format ! 0: procedure ! 1: %spec ! 2: initial call %routine Assemble(%integer amode, labs, names) %switch c(33:127), Pc('A':'Z') %recordformat evfm(%integer low, high, events, label) %record(evfm) event = 0 %record(varfm)%name v %record(varfm)%name gvar {procedure var} %record(stackfm)%name lhs, rhs, x %integer old frame, old extra frame, old jump %integer old temp base, old next temp %integer true frame base, putative frame base, max frame, alt first, alt align=0 %integer old var diags %integer gstart {first descriptor at this level} %integer label start {first label for this level} %owninteger free tag = 0 %integer max local = 0 %integer max parm = 0 %integer min parm = 0 {P1, P2 parameter registers used ?} %integer mark assigned = 1 {mark VAR table entries as 'assigned' if # 0} %integer Closed = Assigned {assume it can't return} %integer Return Label = 0 {label on return code} %integer px = 0 %integer proc ca = ca %integer sw list = 0 %integer last a = -1 %integer line size = 0 %integer block index %integer j, k, t %routinespec compile to string(%record(stackfm)%name v) %routinespec pop lhs %routinespec lrd(%record(stackfm)%name v, %integer reg) %routinespec load(%record(stackfm)%name v, %integer reg) %routinespec assign(%integer assop) %routinespec array ref(%integer mode) %routinespec operate(%integer n) %routinespec compare(%record(stackfm)%name l,r, %integer next) %routinespec test zero(%record(stackfm)%name v) %routinespec header(%record(varfm)%name v) %routinespec block mark(%integer mark) %integerfnspec new tag old jump = uncond jump; uncond jump = -1 old var diags = var diags; var diags = 0 label start = labs old frame = frame; old extra frame = extra frame; extra frame = 0 old temp base = temp base; old next temp = next temp temp base = new temp; Next Temp = New Temp forget the lot: pdisp = 0; wdisp = 0; gdisp = -1; event_events = 0 abort(m'-1 ?') %unless gdisp = -1; !************???????????? gvar == decvar; gstart = names %if amode >= 0 %start; ! NOT A RECORDFORMAT frame = basic frame; ca = 0 level = level+1; abort(m'AM00') %if level > 5 %and spec = 0 local = breg(level) activity(local) = -1 gdisp = (p1-p2)*reglen Reset Optimisation Data %if Spec = 0 %if amode = 0 %start; ! procedure, proc. parameter, %begin block block no = block no + 1; block index = block no block mark(block start) %if sym = 'H' %start; ! %BEGIN block gdisp = -1 %if level = 1 %start; ! Initial %begin ? external id = program ep; ! linkage to program entry otype = external; potype = otype %finish header(gvar) %finish %finish %else %if amode = -1 %start; ! record format gvar_extra = parms frame = 0 %finish true frame base = frame putative frame base = (frame+align)&(\align) frame = putative frame base max frame = frame alt first = parms-1; ! note start of this alternative list %finish ! >> BLOCK MARK << %routine block mark(%integer mark) %integer k, limit k = direct %cycle select output(k) print symbol(mark) %if mark = block start %start print symbol(block index) %if k = object %start; ! procedure head diagnostics put(current line); last line = -15; !force a reset describe(-1,0,block name); ! internal name for procedure %finish %else %if k = direct; ! %and mark = block end (by implication) abort(m'TAG?') %if free tag > 32767; ! too many pass3 tags put(ca>>1); ! code size for this block (half words) put(var diags); ! var. diags local to this block frame = (frame+align)&(\align) k = frame + extra frame; ! include in-frame array space %if control & trusted = 0 %start ! using checked (perm) entry sequence k = k>>2; ! to full word units limit = 65535; ! treated as unsigned 16 bits by perm %else ! in-line entry sequence limit = 32767; ! must be positive 2's complement (byte units) %finish abort(m'FRM?') %unless 0 < k <= limit put(k) print symbol(actual(local)); ! current display register put(event_events); ! events-trapped mask put(event_label); ! Event block ep put(event_low); ! Event block %finish total ca = total ca + ca %finish %exit %if k = object k = object %repeat last ca = -1 %end; ! block mark ! >> SET FRAME PATCH << %routine set frame patch %if diagnose < 0 %start select output(report) print string(" Block index"); write(block index,1) newline select output(object) %finish print symbol(frame patch) %end; ! set frame patch ! >> DEFINE VAR << %routine define var %integer type, form, tf, size, format, s, new, round, dimension %integer ignore; ! ** used to control dumping of diags ** %record(stackfm) temp %integer k !!!*** N.B. On machines with the PDP-11/VAX perversion relating to the order ! of register bytes in store, the following table will have to ! be changed as will a few constants in this routine. ! The relevant piece of record format to consider is: ! (%shortinteger xform %or %byteinteger flag,form) ! which must have the effect of mapping 'flag' onto the ! more significant byte of 'xform'. %constshortintegerarray fmap(0:18) = 0, V in S, {simple variable} A in S, {name: pointer variable} pgm label, {label ** SPECIAL **} 15, {record format **SPECIAL**} 0, {unused} 0, {switch} proc bit<<8 + 0, {routine} proc bit<<8 + V in R, {function} proc bit<<8 + V in S, {map} proc bit<<8 + 5, {predicate} abit<<8 + V in S, {array} anbit<<8 + V in S, {array name} (abit+label bit)<<8 + V in S, {name array} (anbit+label bit)<<8 + V in S, {name array name} ! external manifestations of array forms abit<<8 + V in REC, {external array} anbit<<8 + V in REC, {external array name} (abit+label bit)<<8 + V in REC, {external name array} (anbit+label bit)<<8 + V in REC {external name array name} %constbyteintegerarray vsize(0:8) = 0,4,2,1,8,0,0,4,8 %owninteger prim no = 0 ignore = 0 ignore = 1 %if amode < 0 %or amode = 1; ! no diags for specs of any kind!! internal id = ""; new = 0; round = align decl = tag %if decl = 0 %start; ! RECORD FORMAT ELEMENT NAME parms = parms-1; abort(m'DFV1') %if parms <= names decvar == var(parms) decvar = 0; !(psr) %else abort(m'DFV2') %if decl >= parms decvar == var(decl) %if decl > names %start names = decl; new = 1 decvar = 0 %finish %finish %cycle sym = next; read symbol(next); %exit %if sym = ',' %if length(internal id) # extern len %start internal id = internal id.to string(sym) %finish %repeat ignore = 1 %if internal id = "" tf = tag; read symbol(next) type = tf>>4; form = tf&15 size = tag; read symbol(next) diag type = type; diag form = form; diag size = size %if type = integers %and size # 1 %start; ! INTEGER type = byte %and round = 0 %if size = 2 type = short %and round = 1 %if size = 3 size = vsize(type) %else %if type = 2; ! REAL type = reals ! *** for 8/32, 'round = 3' below should be changed to 'round = 7' !????????????? type = reall %and round = 3 %if size = 4; ! LONG REAL size = vsize(type) %else %if type = 4; ! record type = records format = size decvar_format = format; size = var(format)_length&x'FFFF' %if format <= names %else %if type = 3; ! string type = strings round = 0 decvar_length = size size = size + 1 %else size = vsize(type) %finish decvar_length = size %if type # strings decvar_type = type; decvar_xform = fmap(form) otype = tag spec = (otype>>3)&1; dimension = otype>>8&255; otype = otype&7 %if otype # 0 %start; ! Set external linkage name if appropriate %if otype >= external %start %if alias # "" %start external id = alias %else %if otype = system external id <- system prefix.internal id %else external id = internal id %finish otype = external %if otype <= dynamic {external, system, dynamic} %finish %finish alias = "" %if 7 <= form <= 10 %start; ! PROCEDURE gtype = spec %if otype # 0 %and spec # 0 %start; ! external spec %if otype = primrt %start primno = primno + 1 decvar_flag = decvar_flag ! prim bit decvar_header = prim no; ! *** THIS NEEDS FIXING *** %return %if prim no # 2; ! not READ SYMBOL otype = external; external id = read sym fn; ! see "CALL" %finish gfix(align) decvar_disp = ga; decvar_base = gla external link(ep ref, 0, ga) %return %finish %if gmode = 0 %start; ! NOT A PARAMETER potype = otype %if new # 0 %start; ! NEW NAME decvar_disp = new tag; ! Procedure ID %finish block name = internal id %if spec = 0 %return %finish ignore = 1 otype = 0; size = 4; data size = 4; ! procedure parameter %else data size = size %if form # 1 %start Round = Align %if type = 0 %start; ! General %name ignore = 1 decvar_extra = gmode; ! FOR LABELS type = general; size = 8 decvar_type = general %else %if form = array %or form = name array ignore = 1 size = 0 data size = reglen %if form = name array %else %if form = array name %or form = name array name ignore = 1 size = 2*reglen; round = align; ! array header decvar_header = -1 abort(m'DFV3') %unless 0 < dimension <= 7 decvar_flag = decvar_flag ! dimension; ! 'dim' in low order 3 bits %else size = 4; ! integer (etc) %name %finish %finish %finish %if otype # 0 %start; ! OWN DATA %if otype = con %start; ! CONST INTEGER ETC. data size = 0 %if type=strings %and form=1; ! use actual size %if form = 2 %or form = arrayname %or form = namearrayname %start otype = 0; ! Treat as special later %else ignore = 1; ! no diags for named constants %finish %else gfix(round) set diag(gla,ga) %if ignore # 1 %finish own type = type; own form = form own type = integers %and data size = 4 %if form = 2 decvar_header = -1 %if spec = 0 %start %if form = array %or form = name array %start own form = array; ! to simplify subsequent test at 'A' decvar_flag = decvar_flag&(\array bits)!(anbit!1); ! 1-D %name ! mark as candidate for MHR subscript scaling if bounds do not ! exceed -32768 <= x <= 32767 and data size <= 32767 decvar_flag = decvar_flag ! cheap array bit %if %c 0 < decvar_length <= 32767 %and %c -32768 <= vlb {<= 32767} %and %c {-32768 <=} vub <= 32767 {Note: vlb <= vub-1} gfix(align) set dope vector; ! N.B. changes vlb, vub %if otype # con %start decvar_disp = ga; decvar_base = gla gword rel(ga+8-vlb); ! @A(0) (in gla area) gword crel(dv); ! @dope vector (in code area) %else; ! %const ...... %array claim literal(vub,align); ! no header this time (it's in GLA) select literal area decvar_disp = ga; decvar_base = gla gword crel(ca-vlb) gword crel(dv) select code area %finish external link(data defn,0,ga-8) %if otype = external %finish %else {to RECORD variant with 1-dim bit set, if nesc} decvar_xform = (decvar_xform+3) ! (assigned<<8) decvar_xform = decvar_Xform!1<<8 %if Form >= Array decvar_base = gla; decvar_disp = 0; decvar_extra = ga+8 external link(data ref,0,ga) %finish %return %finish %if form = 3 %start; !%label decvar_disp = new tag %return %finish %if form = switch %start decvar_extra = vlb; decvar_length = vub-vlb+1 decvar_format = free tag + 1; ! base tag claim literal((vub-vlb+1+2)*2,1) decvar_base = code; decvar_disp = litmax select literal area cput(vlb); cput(vub); ! switch bounds %for s = vlb,1,vub %cycle free tag = free tag + 1 define reference(free tag,sw ref) cput(free tag) %repeat select code area %return %finish %if form = record format %start %if gmode # 0 %start frame = decvar_length %if decvar_length > frame %else gtype = -1; spec = -1 %finish %return %finish decvar_base = local %if gdisp >= 0 %and decvar_flag & array bits = 0 %c %and ( (decvar_form = a in s %and decvar_type # general) %c %or (decvar_form = v in s %and decvar_type <= byte) ) %start decvar_disp = gdisp; gdisp = gdisp - reglen decvar_disp = decvar_disp + decvar_type %if %c decvar_form = v in s %and short <= decvar_type <= byte decvar_flag = decvar_flag ! P in R; ! Parameter in Register min parm = min parm + 1; ! for use by 'HEADER' %if control & suppress = 0 %start temp_form = decvar_form; temp_type = decvar_type temp_xbase = decvar_base; temp_disp = decvar_disp %if temp_form = A in S %start temp_form = V in S; temp_type = integers %finish associate(temp, p1 - (min parm-1)) %finish %else frame = (frame+round)&(\round) max local = frame decvar_disp = frame frame = frame + size alt align = alt align ! round %finish set diag(local,decvar_disp) %if ignore = 0 %end; ! define var ! >> CHECKABLE << %predicate checkable(%record(stackfm)%name v) ! Presumes test on 'CONTROL&CHECK UNASS' in line for speed ! Note that a string temporary (v_type = 0) yields FALSE %false %if v_form = constant %or v_form = AV in S %false %if v_flag & assigned # 0 %true %if v_type = integers %or v_type = strings %or v_type >= reals %false %end; ! checkable ! >> DESCRIPTOR << ! N.B. Note that the record zero operation is used, among ! other things, to set the link field to NULL. This ! equivalence between binary zero and NULL links must ! be maintained. %record(stackfm)%map descriptor %record(dfm)%name d %record(stackfm)%name v stp = stp+1; abort(m'DSC1') %if stp > max depth v == desc asl; abort(m'DSC2') %if v == null d == dasl; abort(m'DSC3') %if d == null desc asl == v_link; v = 0 dasl == d_link; d_link == using_link; using_link == d d_d == v %result == v %end ! >> DROP << %routine drop(%record(stackfm)%name descriptor) %record(dfm)%name p,q p == using %cycle q == p_link abort(m'DROP') %if q == null %exit %if q_d == descriptor p == q %repeat p_link == q_link q_link == dasl; dasl == q descriptor_link == desc asl; desc asl == descriptor %end ! >> VSTACK << %routine vstack(%integer var no) %record(varfm)%name w abort(m'VSTK') %unless 0 <= var no <= max vars w == var(varno) lhs == descriptor stacked(stp)_v == lhs lhs_base = w_base lhs_disp = w_disp lhs_format = w_format lhs_extra = w_extra lhs_type = w_type lhs_length = w_length lhs_header = w_header lhs_link == null lhs_type = w_type; lhs_xform = w_xform lhs_dim = w_flag&7; ! in case it's an array lhs_varno = varno monitor(lhs, "V stack") %if diagnose&1 # 0 %end ! >> SSTACK << %routine sstack(%record(stackfm)%name v) %record(stackfm)%name t t == descriptor; t = v stacked(stp)_v == t monitor(t, "S STACK") %if diagnose&1 # 0 %end ! >> C STACK << %routine c stack(%integer n) rhs == descriptor rhs_base = 0 rhs_disp = n rhs_type = integers rhs_form = constant stacked(stp)_v == rhs monitor(rhs, "C stack") %if diagnose&1 # 0 %end ! >> C LOAD << %routine cload(%integer value, reg) c stack(value) pop lhs lrd(lhs,reg) %end ! >> SSET << %routine sset(%integer base, disp, xform, extra) rhs == descriptor rhs_base = base rhs_disp = disp rhs_type = integers rhs_xform = xform rhs_extra = extra rhs_link == null stacked(stp)_v == rhs monitor(rhs, "SSET") %if diagnose&1 # 0 %end ! >> SET LHS << %routine set lhs lhs == stacked(stp)_v monitor(lhs, "SET LHS") %if diagnose&1 # 0 %end ! >> SET BOTH << %routine set both abort(m'SETB') %if stp <= 1 lhs == stacked(stp-1)_v rhs == stacked(stp)_v %if diagnose&1 # 0 %start monitor(lhs, "BOTH LHS") monitor(rhs, "BOTH RHS") %finish %end ! >> POP LHS << %routine pop lhs abort(m'POPL') %if stp <= 0 lhs == stacked(stp)_v stp = stp-1 monitor(lhs, "POP LHS") %if diagnose&1 # 0 %end ! >> POP DROP << %routine pop drop pop lhs monitor(lhs, "POP DROP") %if diagnose&1 # 0 drop(lhs) %end !STRING PROCESSING ! >> DUMP STRING << %routine dump string(%integer max) %integer j %if max = 0 %start; ! DUMP AS MUCH AS NEEDED max = cslen+1 %else; ! DUMP NO MORE THAN MAX %if cslen+1 > max %start ! String constant too long - warn and truncate %if cslen # x'80' %or current string(1) # x'80' %start warn(5); current string(0) = max-1 %finish %finish %finish %if otype = con %start select literal area lit byte(current string(j)) %for j = 0,1,max-1 select code area %else; ! %own gbyte(current string(j)) %for j = 0,1,max-1 %finish %end ! >> GET STRING << %routine get string %integer l l = next; !length cslen = 0 %while l > 0 %cycle l = l-1 read symbol(next) cslen = (cslen+1)&255; current string(cslen) = next %repeat readsymbol(next) %if next # 'A' %and next # '$' %start %if next = '.' %and cslen = 1 %and control&(check capacity!check unass) = 0 %start cstack(current string(1)) Rhs_Flag = Rhs_Flag!Quick Conc %return %finish cstack(0); rhs_type = strings otype = con; ! anonymous %const rhs_base = code; rhs_xform = VinS!(assigned<<8); rhs_format = cslen+1 %if cslen # 0 %or null string = 0 %start claim literal(cslen+1,1); ! Alignment req'd for buffer flushing rhs_disp = lita; dump string(0) null string = rhs_disp %if null string = 0 = cslen %else rhs_disp = null string %finish %else cstack(0); ! explicit string initialisation %finish %end ! >> REAL CONSTANT << %integerfn real constant(%integer force) %owninteger last = 0, next = 0 %integer j,k %ownintegerarray val(0:31) = 0(32) %ownshortintegerarray index(0:31) = 0(32) k = integer(addr(rvalue)) %if otype # con %start gfix(3); gword(k) %result = ga-4 %finish ! deal with %const anonymous or not %if force = 0 %start j = last %cycle -> FOUND %if val(last) = k last = (last+1)&31 %exit %if last = j %repeat claim literal(single,single-1); ! anonymous value not in cache %finish next = (next+1)&31; last = next select literal area val(last) = k; index(last) = ca cword(k) select code area FOUND: %result = index(last) %end; ! real constant !LABEL PROCESSING ! >> NEW TAG << %integerfn new tag free tag = free tag + 1 %result = free tag %end ! >> NEW LABEL << %record(labelfm)%map new label labs = labs+1; abort(m'NLBL') %if labs > max labels %result == labels(labs) %end ! >> FIND << %record(labelfm)%map find(%integer label) %integer lp %record(labelfm)%name l lp = labs %while lp # label start %cycle l == labels(lp) %result == l %if l_id = label lp = lp-1 %repeat %result == null %end ! >> DEFINE LABEL << %routine define label(%integer label) %integer ltag, new %record(labelfm)%name l %record(envfm)%name E cc ca = 0 {must forget condition code} new = 0 %return %if label = 0; ! JUMP AROUND PROCEDURE %if label < 0 %start ltag = -label new = 1 %else l == find(label) %if l == null %start l == new label l_id = label; l_tag = new tag new = 1 %else %if l_tag < 0 %and label >= 0 %start l_tag = new tag new = 1 %finish %finish l_tag = l_tag ! bit15 ltag = l_tag %finish %if new # 0 %start e == environment(label) e_label = 0 %if e ## null %finish define tag(ltag & x'7FFF') merge environment(label) %if uncond jump # ca restore environment(label) %if trace flag # 0 %start dump trace %if next # ':' %and next # 'L' %finish uncond jump = 0; ! YOU CAN GET HERE ! mark assigned = 0; ! can't be sure any more %end; ! define label ! >> JUMP TO << %routine jump to(%integer label, cond, def) %record(labelfm)%name lab %integer ref invert = 0 Cond = Inverted(Cond) %if Cond&16 # 0 %if def >= 0 %start; ! Compiler defined label %return %if label = 0; ! jump round routine %if label < 0 %start j tag = -label %else lab == find(label) %if lab == null %start lab == new label lab_id = label; lab_tag = new tag remember environment(label) %else %if lab_tag < 0 %and def = redefine old lab_tag = new tag remember environment(label) %else merge environment(label) %if lab_tag > 0 %finish j tag = lab_tag&x'7FFF' %finish %else; ! Tag internal to pass 2 jtag = label; ! *** N.B. This is %not a pass1-visible label *** %finish %if cond = jump %then ref = j ref %else ref = c ref define reference(j tag,ref) cput(jtag<<4 + cond&15); cc ca = cc ca + 2; ! these two bytes can't change CC %if cond = jump %start uncond jump = ca; ! no way past here trace flag = control&trace %if next = ':'; ! to catch 'else', 'repeat' etc %else trace flag = control&trace; ! maybe trace flow on next line %finish mark assigned = 0 %end; ! jump to ! >> FLOAT << %routine float(%record(stackfm)%name v, %integer r) ! Convert 'v' into floating point form %integer k !!!!!%longreal x r = fpr %if r = anyf %if const(v) %start %if v_disp = 0 %start hazard(r); claim(r) rr(sub,r,r); claim(r) v_type = reall; v_form = v in r; v_base = r %else rvalue = v_disp; ! ** IMPLICIT FLOATING ** otype = con; k = real constant(0) v_xform = (assigned<<8) ! V in S; v_type = reals v_base = code; v_disp = k %finish %else load(v,any) rr(flr,r,v_base); claim(r) v_form = v in r; v_type = reall v_base = r %finish %end ! >> LRD << %routine lrd(%record(stackfm)%name v, %integer reg) ! load, release and drop load(v,reg) release(v_base) drop(v) %end ! >> QUICK LOAD << %routine QUICK LOAD(%integer reg, form, base, disp) %record(stackfm) v v = 0 v_type = integers; v_form = form v_base = base; v_disp = disp load(v, reg) %end ! >> REDUCE << %routine reduce(%record(stackfm)%name v) %integer type, xform, disp, base xform = v_xform - 3; ! X in REC => X in S type = v_type disp = v_disp; base = v_base v_disp = v_extra; v_type = integers; v_form = v in s load(v,any) v_type = type; v_xform = xform & (\(assigned<<8)) v_disp = disp %end ! >> AMAP << %routine amap(%record(stackfm)%name v) ! convert V into a descriptor for the address of V %integer f %constshortintegerarray map(0:15) = -1, -2, -3, -4, av in s, -5, v in s, av in rec, -6, v in rec, -7, -8, -9, -10, -11 {PGM LABEL}, -12 {record format} f = map(v_form) %if f < 0 %start abort(m'AMAP') %unless v_form = pgm label ! Deal with ADDR(pgm label) f = gpr; forget reg(1<> AMAPS << %routine amaps(%record(stackfm)%name v) %integer t,l t = v_type; l = v_length amap(v) %return %if t # strings; ! put length in top byte reduce(v) %if v_form >= V in REC load(v,any) %if v_form = V in S %or v_Form = AinS !! It must be: const, V in R or AV in S v_disp = v_disp + l<<24 v_form = AV in S %end ! >> VMAP << %routine vmap(%record(stackfm)%name v) ! The inverse of AMAP: i.e. vmap(amap(x)) => x %integer mod, f, t %constshortintegerarray map(0:8) = v in s, v in s, -1, -2, a in s, v in s, -3, a in rec, v in rec mod = 0 %if v_oper # 0 %start %if (v_oper=add %or v_oper=sub) %and const(v_link) %start mod = v_link_disp mod = -mod %if v_oper = sub v_oper = 0; drop(v_link) %finish load(v,any) %else %if v_form = a in s %or v_form = a in rec T = V_Type Amap(V) load(v,any) V_Type = T; V_Form = VinS %finish f = map(v_form); abort(m'VMAP') %if f < 0 v_form = f v_disp = v_disp + mod %end; ! v map ! >> ADDRESS << %routine address(%record(stackfm)%name v, %integer mode) ! convert V into a form in which it is directly addressable ! MODE parameter specifies what type of result is required. ! >= 0 : a value (RHS) ! < 0 : a name (LHS) ! Further, if MODE > 0, the value is taken to specify the target register ! for any LOAD which may be generated. %integer type, form, reg, d, cr %ownrecord(stackfm)%name last == (0); ! ***** null actually ****** UGH monitor(v, "ADDRESS") %if diagnose&2 # 0 reg = mode %if reg <= 0 %start reg = any reg = anyf %if v_type >= reals %or (v_oper # 0 %and floating(v)) %finish cr = reg; !*psr* %if v_oper # 0 %start; ! compound object %if v_oper = ADD %and const(v_link) %and v_type <= BYTE %start d = v_link_disp; drop(v_link) v_oper = 0 load(v,reg) v_disp = d; v_form = AV in S %else load(v,reg) %finish ->SET CR %finish form = v_form; type = v_type %if form >= V in REC %start reduce(v); form = v_form %finish %if control & suppress = 0 %start cheap reg = cr cheapen(v,mode) cr = cheap reg form = v_form %finish ->SET CR %if form = V in R %or form = constant %if form = AV in S %start %if v_base = 0 %start v_form = constant %else %if v_disp = 0 v_form = V in R %finish ->SET CR %finish %if form = A in S %start v_form = V in S; v_type = integers load(v,any) v_type = type; v_xform = (v_flag&(\assigned))<<8 ! V in S; v_disp = 0 form = V in S %finish %if %not last == v %start; ! *** FRIG: to prevent mutually recursive loop last == v %if mode >= 0 %and ((control&check unass#0 %and v_type#strings %c %and checkable(v)) %or v_type = byte) %start load(v,reg) %finish last == null %finish SET CR: cheap reg = cr %end; ! address ! >> LOAD << %routine load(%record(stackfm)%name v, %integer r) ! load the entity described by V into register R %record(stackfm)%name w %switch f(constant:a in rec), iop(not:rdiv), rop(not:rdiv) %record(stackfm) z %record(stackfm)%name temp rhs %integer op, d, type, temp, n, uflag %constbyteintegerarray twin(R0:R15) = R1,R0, R3,R2, R5,R4, R7,R6, R9,R8, R11,R10, R13,R12, R15,R14 %routine PICKUP(%record(stackfm)%name V) %integer old load(v, r) %if R = Any %or R = AnyF %start old = R; R = V_Base %return %if Activity(R) = 1 %or (Activity(R)=2 %and W_Base = R) %if old = Any %then R = Gpr %else R = Fpr Load(V, R) %else abort(m'Pick') %if activity(r) # 1 %finish %end monitor(v, "LOAD") %if diagnose&2 # 0 -> realv %if floating(v) %or fr0 <= r <= fr14 %or r = anyf op = v_oper; v_oper = 0 %if op # 0 %start w == v_link; {address(w,0)}; ! records reduced here load(w,any) %if w_base = r # v_base; ! *** FRIG: to avoid problem ! with HAZARD and e.g. -> sw( -A(j) ) -> iop(op) %finish amap(v) %if v_type = 0 %or v_type = strings %or v_type = records address(v,r) %if r = any %start %return %if v_form = VinR %if v_form = AV in S %and activity(v_base) = 1 %and -15 <= v_disp <= 15 %start r = v_base %else r = gpr %finish %else %if v_base = r %start %if activity(r) > 1 %start {protect other uses} release(r); v_base = 0 hazard(r) claim(r); v_base = r %finish %else hazard(r) %finish %finish -> f(v_form) f(av in rec): f(a in rec): f(v in rec): f(A in S): abort(m'LD1'); ! These forms should have been simplified by ADDRESS f(av in s): f(constant): abort(m'LD2') %if v_type >= reals rxi(lw,r,v_base,v_disp) forget reg(1< CSET ! integer operations iop(and): %if control&check unass = 0 %and w_form = constant %start address(v, r) %if w_disp = x'FFFF' %start %if v_form = VinS %and (v_type = integers %or v_type = short) %start v_disp = v_disp+2 %if v_type = integers LOADL: v_type = 255 drop(w) Load(V, R) %return %finish %else %if w_disp = 255 drop(w) %if v_form = VinR %start r = gpr %if r = any rr(LBR, r, v_base) ->CSETI %finish %if v_type = integers %start v_disp = v_disp+3 %else %if v_type = short v_disp = v_disp+1 %finish v_type = byte load(v, r) %return %finish %finish {** Drops through **} iop(add): iop(sub): iop(or): iop(xor): pickup(v) {sets R} address(w, 0) {**Moved down one line**} rxd(op,r,w) -> end op iop(rsh): %if control&check unass = 0 %and w_form = constant %and w_disp = 16 %start address(v, r) ->LOADL %if v_form = VinS %and v_type = integers %finish iop(lsh): %if w_form # constant %and control&check capacity # 0 %start load(w,r2); perm(vschk) %finish pickup(v) {sets R} %if w_form = constant %start warn(6) %unless 0 <= w_disp <= 8*reglen-1 %else; ! variable shift load(w,any) %if w_form # V in R w_disp = 0 %finish rxi(op,v_base,w_base,w_disp) -> end op ! these operations are changed immediately into binary subtracts ! and should themselves never appear in LOAD ! -x => 0 - x ! \x => -1 - x (assumes 2's complement) iop(not): iop(neg): abort(m'LD4') iop(div): %if w_form = constant %start n = power(w_disp) %if n > 0 %start Pickup(V) {make sure it's in the correct register} Test Zero(v); r = v_base claim(r) d = 1; d = 2 %if n > 4; ! 1 or 2 halfwords skip(d, greater or equal) rxi(ADD, v_base, 0, \((-1)<END OP %finish %finish {** Drops through **} ! *** N.B. *** ! The multiply routine below is not intended for use in array subscript ! calculation as it will include an overflow check. Currently all in-line ! subscript scaling uses shift or 'multiply halfword' instructions. iop(mul): iop(rem): %if r = any %start n = 0; n = 1 %if op = MUL %if in free reg(v) %and actual(v_base)&1 = n %c %and activity(twin(v_base)) = 0 %start temp = v_base temp = twin(temp) %if op # MUL %else temp = even odd pair %finish %else %if actual(r)&1 # 0 %and activity(twin(r)) = 0 %start temp = r %else temp = even odd pair %finish %finish n = twin(temp) claim(n); load(v,temp) release(n); hazard(n); claim(n) d = op %if op # MUL %start rr(lw,n,temp); claim(temp) rxi(sra,n,0,31); ! propagate sign d = div %finish forget reg( (2+1)< end op ! Special multiply routine used for array subscript scaling where all values ! involved are in range: -32768 <= x <= +32767 iop(mult16): %if r = v_base %or v_type = byte %start load(v,any) %else address(v,0) load(v,any) %if v_form # V in S %and v_form # V in R %and v_form # constant %finish v_disp = v_disp+reglen//2 %if v_type = integers; ! ** halfword instruction!! ** pickup(w); ! scale factor (data size) - & sets R rxd(mult16,r,v) v_base = r; v_disp = 0; v_xform = V in R -> end op iop(exp): load(v,r3); load(w,r2) release(r3); release(r2) perm(iexp) claim(r1); v_base = r1 -> end op iop(conc): address(v, r) %if v_type # 0 %start pdisp = basic frame %if pdisp = 0 ! N.B. Must %not corrupt LHS/RHS in LOAD temp rhs == rhs sset(wsp,pdisp,V in S,0); rhs_type = strings; rhs_length = 255 rhs == temp rhs sstack(v); v_Base = 0 assign(1) claim(r2) v_type = strings; v_form = VinS v_base = r2; v_disp = 0 v_length = 255; ! it's a temporary now pdisp = pdisp + 256; ! ... so protect it %finish %if w_flag & quick conc # 0 %start; ! S = S.tostring(sym) z = v; claim(z_base); z_type = byte load(z, any) rxi(LW, z_base, z_base, 1); claim(z_base) {length+1} load(w, any) {character} v_index = z_base; v_type = byte; v_form = VinS rxd(ST, w_base, v); release(w_base) claim(v_base); v_index = 0 rxd(ST, z_base, v) %else load(v, r2) load(w,r1); release(r1); release(r2) n = v_length; n = 255 %if n = 0 perm(sconc); cput(n) v_form = VinS %finish claim(v_base) v_type = 0 %if r # any %and r # 0 %start; ! not from OPERATE load(v,r); v_type = 0; v_form = v in s %finish drop(w) %return {Note: nothing to forget} ! floating operations REALV: abort(m'LD5') %if r = any; ! should be floating register op = v_oper; v_oper = 0 %if op # 0 %start w == v_link -> rop(op) rop(not): rop(lsh): rop(rsh): rop(and): rop(or): rop(xor): rop(conc): rop(mult16): abort(m'LD6'); ! inappropriate operator rop(rdiv): op = div rop(div): rop(add): rop(sub): rop(mul): %if w_type < reals %start float(w, anyf) %if w_form = V in R # v_form %and v_type >= reals %c %and (op = add %or op = mul) %start z = v; v = w; w = z; ! interchange %finish %finish Pickup(v); r = v_base Address(W, 0) rxd(op,r,w) -> end op rop(neg): abort(m'LD7'); ! should have been modified by OPERATE %finish float(v, r) %if v_type < reals address(v, r) {AFTER float to prevent optimising constants} {e.g. I=0; R=0} %if v_form = v in r %start %return %if r = anyf %or v_base = r hazard(r); rr(lw,r,v_base) v_base = r; claim(r) %return %finish %if r = anyf %start r = fpr %else hazard(r) %unless r = v_base %finish abort(m'LD8') %unless fr0 <= r <= fr14 -> f(v_form) rop(rexp): abort(m'LD9') %if w_type >= reals load(v,fr2); load(w,r1) release(fr2); release(r1) perm(fexp); ! floating exponent claim(fr0); v_base = fr0 END OP: V_Type = Integers %if V_Type <= Byte forget reg(1<> COP << %routine cop(%integer op, %record(stackfm)%name lh,rh) ! perform a compile-time operation %constinteger fp tens=70; ! max powers of ten available in floating point %integer l,r %switch s(1:rdiv) %integerfn p10(%integer n); ! approximate powers of ten in 'n' %integer value, power value = 1; power = 0 %cycle %result = power %if value >= n value = value*10 power = power+1 abort(m'COP1') %if power > 100 %repeat %end l = lh_disp; r = rh_disp -> s(op) s(NEG): s(NOT): s(CONC): abort(m'COP2') s(ADD): l = l+r; -> EXIT s(SUB): l = l-r; -> EXIT s(OR): l = l!R; -> EXIT s(AND): l = l&r; -> EXIT s(XOR): l = l!!R; -> EXIT s(LSH): l = l< EXIT s(MUL): l = l*r; -> EXIT s(MULT16): l = l*r; -> EXIT s(RSH): l = l>>r; -> EXIT s(EXP): l = l^^r; -> EXIT s(DIV): warn(1) %and r = 1 %if r = 0 l = l//r; -> EXIT s(REM): warn(1) %and r = 1 %if r = 0 l = l-l//r*r; -> EXIT s(REXP): warn(7) %and r = 0 %if p10(|l|) * r > fp tens rvalue = l^r; ! **** implicit floating **** -> REAL s(RDIV): warn(1) %and r = 1 %if r = 0 rvalue = l/r; ! **** implicit floating **** REAL: otype = con; l = real constant(0) lh_base = code lh_type = reall; lh_form = V in S EXIT: lh_disp = l %end ! >> OPERATE << %routine operate(%integer oper) ! perform the operation OPER on the top two elements of the stack. ! (single element for unary operators) %record(stackfm)%name lh,rh,with %integer key,lcon,rcon,wcon,lop %constbyteintegerarray transitive(add:rdiv) = 0,0,1,15(2),1(3),15(2),1,15(4) %constbyteintegerarray commutative(add:rdiv) = 1,0,1,0,0,1(3),0(2),1,0(4) %constshortintegerarray nop value(add:rdiv) = 0,0,1(2),0,-1,0(4),1,1(4) %routine pickup(%record(stackfm)%name v) %if floating(v) %then load(v,anyf) %else load(v,any) %end stp = stp-1 lcon = 0; rcon = 0; wcon = 0 lh == stacked(stp)_v %if const(lh) %start lcon = 1 %else %if lh_type # strings %and lh_type # 0 address(lh, 0) %if lh_oper = 0 %finish rh == stacked(stp+1)_v %if const(rh) %start rcon = 1 %if oper = sub %start oper = add; rh_disp = -rh_disp %finish %finish %if lh_oper # 0 %start lop = lh_oper with == lh_link wcon = 1 %if const(with) %if wcon&rcon # 0 %start; !! fold key = transitive(oper)!transitive(lop) %if key = 0 %or (key = 1 %and oper = lop) %start with_disp = -with_disp %and lop = add %if lop = sub cop(oper,rh,with); drop(with) lh_link == rh lh_oper = lop -> STRIP NOP %finish %finish pickup(lh) %finish %if rcon # 0 %start %if lcon#0 %or (oper=ADD %and lh_type=INTEGERS %and (lh_form=VinR %or lh_form=AVinS)) %start lh_form = AV in S %if lh_form = VinR cop(oper,lh,rh); drop(rh) %return %finish %finish %if rh_oper # 0 %start pickup(rh) %else %if rcon # 0 %and rh_disp = 2 ! treat *2 (real & integer) and ^2, ^^2 specially %if oper = mul %or oper = exp %or oper = rexp %start %if oper = mul %then oper = add %else oper = mul rh = lh; rcon = 0; claim(rh_base) %finish %finish %if commutative(oper) # 0 %and ( lcon # 0 %c %or ( lh_form # VinR %and rh_form = VinR %and activity(rh_base) >= 0 ) ) %start rh_link == lh stacked(stp)_v == rh rh_oper = oper ! keep various items valid for use at STRIP NOP: with == rh; rh == lh; lh == with rcon = lcon %else lh_oper = oper; lh_link == rh %finish STRIP NOP: %if rcon # 0 %start %if rh_disp = nop value(oper) %start lh_oper = 0; drop(rh) %else %if oper = MUL %and control&check capacity = 0 key = power(rh_disp) %if key > 0 %start lh_oper = lsh; rh_disp = key %finish %finish %finish %end; ! operate ! >> ASSIGN << %routine assign(%integer assop) ! ASSOP = -1: parameter assignment ! 0: == assignment ! 1: = assignment ! 2: <- assignment ! 3: Unchecked string move - either for speed or P in R %constbyteintegerarray string move(-1:3) = SMOVE, 0, SMOVE, SJAM, SMOVOPT %record(stackfm)%name lh,rh,x %record(stackfm) temp %integer n,p,t,op,insert,form,lhdisp insert = 0 abort(m'ASS1') %if stp < 2 rh == stacked(stp)_v lh == stacked(stp-1)_v form = lh_form; ! to avoid the ravages of amap, load etc %if diagnose&4 # 0 %start monitor(lh, "ASS LH") monitor(rh, "ASS RH") %finish %if assop < 0 %start; ! Parameter %if lh_flag & prim bit # 0 %start; ! Special - prim routine temp = lh; lh = rh; rh = temp p disp = 0 %return %finish lh_extra = lh_extra - 1 vstack(lh_extra); lh == stacked(stp)_v form = lh_form; lh disp = lh_disp; ! preserve original values assop = 0 %if lh_form # v in s %if lh_flag & p in r = 0 %start; ! not an in-register parameter p disp = lh_disp + lh_length p disp = p disp+1 %if lh_type = strings %and Form = VinS lh_disp = lh_disp + wdisp; ! adjust for nested calls %finish %if lh_flag & proc bit # 0 %start; ! Procedure parameter assop = 1 lh_type = integers; lh_form = v in s rh_type = integers; rh_form = av in s %if rh_base # 0 %and rh_base # gla %start; ! param already rh_form = v in s %else %if rh_base = gla; ! non-local external rh_disp = rh_disp-5*reglen; !dummy environment %else; ! local routine p = (frame+3)&(\3) frame = p+8*reglen t = rh_disp; !proc tag rh_disp = p; rh_base = local define reference(t, r ref) rx(la, link, code, 0) rx(stm, r8, local, p) %finish %finish %finish stp = stp-2 %if rh_flag & array bits # 0 %start; ! Arrayname p disp = lh_disp + 2*reglen hazard(r0) address(lh,-1); address(rh,-1) %if rh_header = -1 %start; ! Simple case rx(lw,r0,rh_base,rh_disp); ! @A(0) %else; ! Array-in-record rxi(lw,r0,rh_base,rh_disp) rx(add,r0,gla,rh_header) rh_disp = rh_header; rh_base = GLA %finish %if lh_type = strings %and lh_length = 0 %start; ! %string(*)%arrayname RXI(ADD,r0,0,rh_length<<24); ! length in top byte %finish forget reg(1< physical length amaps(rh); lrd(rh,any); p = rh_base rx(st,p,lh_base,lh_disp) claim(lh_base) cload((n<<4) + genmap(t),p) rx(st,p,lh_base,lh_disp+reglen) drop(lh) %return %finish %if assop = 0 %start; ! == amap(lh); ! destination %if lh_length = 0 %then amaps(rh) %else amap(rh); ! %string(*)%name ? %finish %if Lh_Type = Records %start n = Min Record Size(Lh, Rh) %if rh_Form # Constant %start lrd(rh,r1); ! source area op = rcopy; ! copy record %else drop(rh) op = rzero; ! clear record %finish lrd(lh,r2); ! destination area cload(n>>2,R3); ! R3 = no. of WORDS to copy/zero perm(op) %return %finish %if lh_type = strings %and lh_flag & p in r = 0 %start %if assop > 0 %and rh_format = 1 %start; ! null string as zero byte ? drop(rh) lh_type = byte; sstack(lh); drop(lh) cstack(0); assign(assop) %return %finish p = lh_length %if assop # 2 %and same(lh,rh) %start; ! S = S or S = S.T %if rh_oper = 0 %start drop(lh); drop(rh); ! S = S %else rh_length = p release(lh_base); drop(lh) rh_type = 0{; address(rh,-1)}; lrd(rh,0) {0 = special for CONC} %finish %else %if Control&Trusted # 0 %and assop # 2 %and Rh_Oper # 0 %and %not Same(Lh, Rh) %and %not Same(Lh, Rh_Link) x == Rh_Link; Rh_Oper = 0 Load(Lh, R2); Lrd(Rh, R1) Perm(String Move(3)) Lh_Form = VinS; Lh_Type = 0 Lh_Oper = Conc; Lh_Link == X Lrd(Lh, 0) %else; ! general case rh_flag = rh_flag&(\quick conc); ! quicky not possible after all. ! use fast string move if 'trusted' or capacity exceeded is impossible ! and unassigned is not requested or impossible. %if assop # 2 %start; ! not jam transfer assop = 3 %if control & trusted # 0 %c %or ( p >= rh_length %c %and (control&check unass = 0 %or %not checkable(rh)) ) %finish %if rh_oper = 0 %start; !simple, so protect lhs first: s(j)=t lrd(lh, r2); lrd(rh, r1) %else; !simplify rh first: s = t.u lrd(rh, r1); lrd(lh, r2) %finish perm( string move(assop) ) cput(p) %if assop # 3; ! max. length of destination for check ? %finish %return %finish %if lh_flag & p in r # 0 %start p = p1; p = p2 %if lh disp < reglen; p = p3 %if lh_type = strings load(rh,p) %if rh_oper # 0 drop(lh) lh == stacked(stp)_v rh_oper = p; ! target register rh_link == lh_link; lh_link == rh address(lh, -1) %else ! Test for case where add-to-memory can profitably be used. ! Note that the effective no-op of self-assignment can be detected easily address(lh, -1) %if control & check bits = 0 %and rh_type <= short %C %and (rh_oper = 0 %or rh_oper = ADD) %and same(lh,rh) %start %if rh_oper = 0 %start; ! assignment-to-self release(rh_base); drop(rh) release(lh_base); drop(lh) %return %finish ! General case: add-to-memory x == rh; rh == rh_link release(x_base); drop(x) load(rh,any) address(lh,-1); rxd(AM,rh_base,lh) forget var(lh) release(rh_base); drop(rh); drop(lh) %return %finish ! test for assignment of small constants to %short and %byte t = rh_type %if rh_base = 0 %and rh_form = constant %and rh_Oper = 0 %start %if -32768 <= rh_disp <= 32767 %start %if rh_disp&(\255) = 0 %start t = byte %else t = short %finish %finish %finish ! . . . then suppress capacity check if LH is real or length RH is ! not greater than length LH. n = assop assop = 2 %if lh_type > byte %or lh_type <= t %if Lh_Form = VinR %start {special by PSR - is it safe????} Load(Rh, Lh_Base) Assop = 2 %else p = cheap reg {preferred register} float(rh, p) %if lh_type >= reals %and %not floating(rh) {Float here to prevent optimising the integer value} address(rh, p) {see where it is} load(rh, p) %unless rh_form = VinR p = rh_base address(lh, -1) %unless lh_form = VinS rxd(ST, p, lh) %if control & suppress = 0 %start t = activity(lh_base) %if t < 0 %or control&trusted # 0 %start forget var(lh) %if mark assigned # 0 %and lh_base = local %start; ! set 'assigned' ? var(lh_varno)_flag = var(lh_varno)_flag ! assigned %finish %else forget all %finish lh_flag = lh_flag ! (rh_flag & assigned) associate(lh,p) %if n # 2; ! not jam transfer %finish release(p) %finish drop(lh); drop(rh) %finish %if assop = 1 %and control&check capacity # 0 %start %if lh_type = short %start claim(p); rr(chvr,p,p) perm(cap16); ! Test for 16-bit overflow %else rxi(TEST,p,0,\255); ! should give zero result perm(cap8); ! Test for 8-bit overflow %finish %finish %end; ! assign ! >> LOAD PARAMS << %routine load params(%record(stackfm)%name v) ! called at c('E') to load in-register parameters set by ASSIGN above %integer reg %record(stackfm)%name next %return %if v == null reg = v_oper v_oper = 0 next == v_link load(v,reg) load params(next) release(reg) drop(v) %end; ! load params ! >> ARRAY REF << %routine array ref(%integer mode) ! Array references are by perm call except in the case of unchecked 1-D arrays ! which either: ! (i) have a data size which is an integral power of 2, not greater than 16384. ! or: ! (ii) have data size <= 32768 and constant bounds -32768 <= x <= 32767. %integer flags, p, type, base, assbit %integer mult, shift; ! ** PRESUMED SET BY 'UNCHECKED REF' %record(stackfm)%name temp %predicate special case shift = power(mult) %true %if shift >= 0 %or flags & cheap array bit # 0 %or Base = 0 %false %end; ! special case %routine unchecked ref %integer header, length, format, extra header = lhs_header; length = lhs_length; format = lhs_format extra = 0 %if rhs_oper = ADD %or (rhs_oper = 0 %and (rhs_form = AV in S %or rhs_form = Constant)) %start %if rhs_oper = ADD %start %if rhs_link_form = constant %or rhs_link_form = AV in S %start extra = rhs_link_disp %if rhs_link_form = AV in S %start; ! => VinR + const (see below) rhs_link_form = VinR rhs_link_disp = 0 %else; ! simple constant rhs_oper = 0 drop(rhs_link) %finish %finish %else; ! AV in S (treat as VinR + constant) extra = rhs_disp; rhs_disp = 0 rhs_form = VinR %if rhs_form = AVinS %finish extra = extra * mult %finish %if shift >= 0 %start cstack(shift); operate(lsh) %else cstack(mult); operate(mult16) %finish lhs_type = integers; ! address calculation %if lhs_header >= 0 %start; ! array-in-record amap(lhs); ! address of record containing array sset(gla,lhs_header,v in s,0) operate(add) %finish operate(add) set lhs ! ! ***** F R I G ***** ! load(lhs,any) %if lhs_oper = 0; ! Force load: zero subscript folded out ! ! ***** F R I G ***** ! vmap(lhs) ! lhs_disp = lhs_disp + extra ! lhs_type = type ! lhs_format = format; lhs_length = length ! lhs_xform = assbit ! V in S ! lhs_form = A in S %if flags & label bit # 0 %if Extra # 0 %start Cstack(Extra); Operate(Add) Set Lhs %finish Vmap(Lhs) Vmap(Lhs) %if Flags&Label Bit # 0 {namearray} Lhs_Type = Type Lhs_Format = Format Lhs_Length = Length Lhs_Xform = Lhs_Form!Assbit %end %if mode # 0 %start; ! multi-dimensional: ingest non-terminal subscripts set both; stp = stp-1 load(rhs,any) %if rhs_oper # 0 rhs_link == lhs_link lhs_link == rhs lhs_oper = lhs_oper+1 %return %finish set both abort(m'ARF1') %if lhs_oper+1 # lhs_dim; ! No. of subscripts ? flags = lhs_flag; ! protect from ravages of AMAP lhs_flag = lhs_flag & (\(label bit + array bits)) base = lhs_base; type = lhs_type; assbit = lhs_xform & (assigned<<8) %if (control & check array = 0 %and lhs_oper = 0) %or Base = 0 %start; ! unchecked 1-D mult = lhs_length mult = mult+1 %if lhs_type = strings mult = 4 %if Flags&Label Bit # 0; !namearray %if special case %start; ! sets 'shift' as a side-effect unchecked ref; %return %finish %finish stp = stp-1 %if lhs_oper = 0 %start; ! 1-D load(rhs,r1); drop(rhs) p = aref1 %else %if lhs_oper = 1; ! 2-D load(lhs_link,r1); drop(lhs_link) load(rhs,r2); drop(rhs) p = aref2 p = aref4 %if control & check array = 0 %else; ! 3-D or more load(rhs, any) %if rhs_oper # 0 {**psr**} rhs_link == lhs_link; ! tack on last subscript %for p = pdisp,reglen,pdisp+(lhs_oper-1)*reglen %cycle temp == rhs_link lrd(rhs,any) {**psr**} rx(ST,rhs_base,wsp,p) {**psr**} rhs == temp %repeat load(rhs,r1); ! r1 = first subscript rhs_form = AV in S; rhs_base = wsp; rhs_disp = pdisp load(rhs,r2); ! r2 = addr(subscript list) drop(rhs) p = aref3 %finish lhs_oper = 0 amap(lhs) %if lhs_header >= 0 %start; ! array-within-record sset(gla,lhs_header,av in s,0) load(rhs,r3); drop(rhs); stp = stp-1 %else load(lhs,r3) %finish release(r1); release(r3) release(r2) %unless p = aref1 perm(p) claim(r1) %if lhs_header >= 0 %start; ! array-in-record sset(lhs_base,lhs_disp,lhs_form,lhs_extra); ! address of record lhs_base = r1; lhs_disp = 0; lhs_form = VinR; ! array component lhs_type = integers; ! an address to be amapped operate(add); ! record address + array component %else lhs_base = r1; lhs_disp = 0 %finish vmap(lhs) lhs_type = type lhs_xform = assbit ! V in S lhs_form = A in S %if flags & label bit # 0 %end; ! array ref ! >> TEST ZERO << %routine test zero(%record(stackfm)%name v) %record(stackfm)%name w %integer cr cr = any cr = anyf %if floating(v) %if v_oper = AND %and sym = '?' %and const(v_link) %start ! if x & const = 0 . . . . . . . w == v_link; v_oper = 0 load(v,cr) rxd(TEST,v_base,w) drop(w); release(v_base) %else load(v,cr) %if ca # cc ca %or cc reg # v_base %start rr(lw,v_base,v_base) %else release(v_base) %finish %finish %end; ! test zero %routine Compare Records(%record(stackfm)%name L, R, %integer N) Amap(l); Load(l, R1) Amap(r); Load(r, R2) Cload(n, R3); Set Both {***beware of CLOAD and Lhs} Release(R1); Release(R2) Perm(Rcomp) %end ! >> COMPARE REALS << %routine compare reals(%record(stackfm)%name l,r) load(l,anyf) address(r,0) float(r, anyf) %unless floating(r) rxd(cmp,l_base,r) release(l_base) %end; ! compare reals ! >> COMPARE STRINGS << %routine compare strings(%record(stackfm)%name l,r) %record(stackfm)%name temp %if l_base = code %and l_disp = null string %start temp == r; r == l; l == temp invert = invert !! 16 %finish %if r_base = code %and r_disp = null string %start load(l,any) %if l_oper # 0 l_type = byte test zero(l) %else load(r,r2) %if r_oper # 0 load(l,r1); load(r,r2) release(r1); release(r2) perm(scomp) %finish l_type = strings; l_form = v in s p disp = 0 %end; ! compare strings ! >> COMPARE << %routine compare(%record(stackfm)%name l,r, %integer next) swopped = 0 %if l_type = 0 %or l_type = strings %start compare strings(l,r); %return %finish %if zero(r) %start test zero(l); %return %finish %if zero(l) %start test zero(r); invert = invert !! 16 %return %finish %if floating(l) %or floating(r) %start compare reals(l,r); %return %finish %if L_Type = Records %start Compare Records(L, R, Min Record Size(L, R)) %return %finish address(l,0); load(l,any) address(r,0) %if '=' # next # '#' %start rxd(cmp,l_base,r) %else rxd(clw,l_base,r) %finish release(l_base) %end; ! compare ! >> RESOLVE << %routine resolve(%integer flag) !S -> A.(B).C %record(stackfm)%name s,a,b,c %integer p,q cstack(0) %if flag&1 = 0; ! C missing pop lhs; c == lhs pop lhs; b == lhs cstack(0) %if flag&2 = 0; ! A missing pop lhs; a == lhs pop lhs; s == lhs load(s,r3); load(a,r2); load(b,r1); load(c,r4) p = a_length; !!!!! p = 255 %if p = 0 q = c_length; !!!!! q = 255 %if q = 0 release(r3); drop(s) release(r2); drop(a) release(r1); drop(b) release(r4); drop(c) perm(sresln); cput( (p<<8) + (q&255) ); ! conditional resolution %if flag&4 = 0 %start; ! unconditional perm(sresv); ! verify it succeeded %finish %end; ! resolve ! >> HEADER << %routine header(%record(varfm)%name v) frame = basic frame %if frame < basic frame define tag(v_disp&x'FFF') rx(stm, p2+2-minparm, wsp, (2-minparm)*reglen) %if potype >= external %start !===== the order of the next two statements is critical ===== external link(ep defn,0,0) rx(st,link,wsp,(link-p2)*reglen) %if control&unass # 0 %and unassigned rtn = 0 %start ! Force inclusion of unassigned check routine if not already present unassigned rtn = 1 select output(direct) print symbol(p ref); put(asschk); put(0) select output(object) %finish %finish rr(lw,local,wsp) %if v_header # 0 %start; ! special string parameter (P in R) abort(m'HDR1') %if v == begin sset(local,v_header,V in S,0); rhs_type = strings sset(p3,0,VinR,0) claim(P3); ! parameter nominally at 0(P3) assign(3); ! SMOVOPT %if control&trusted # 0 %start; ! suppress check if 'TRUSTED' v_header = 0 %else Cput(x'0812') {preserve R2 for later} %finish %finish frame = (frame+align)&(\align); ! ensure non-parameter locals are aligned %if control & trusted = 0 %start; ! stack overflow check perm(pentc); ! checked procedure entry *** mustn't corrupt R2 *** cput(frame); ! parameter size cput(0); ! padding:- gets overwritten %else rxi(add,wsp,0,basic frame); ! 2nd. halfword gets overwritten %finish set frame patch; ! Total size ! Use base reg(5) to hold unassigned pattern ( except at level 5 !! ) %if level # 5 %and control & check unass # 0 %start rx(lw,base5,code,unass) activity(base5) = -1; ! lock it %finish %if v_header # 0 %start; ! check P in R string Cput(x'0821') {*LR_2,1} perm(smove) cput(ap_length); ! 'AP' set at '}' v_header = 0 %finish %if control&trace # 0 %start; ! trace option enabled %if v == begin %and potype >= external %start; ! main program %begin external id = trace routine external link(ep ref,0,ga) perm(enter trace); cput(0); ! initialise user-supplied routine %finish trace flag = control&trace %finish event = 0 %end; ! header ! >> RETURN << %routine return %return %if uncond jump = ca; ! can't get here ? %if Return Label # 0 %start Jump To(Return Label, Jump, Define New) %else Return Label = x'7001' {something positive and unique} Define Label(Return Label) rx(lm,wsp,local,(wsp-p2)*reglen) rr(jmp,always,link) %finish uncond jump = ca Closed = 0 {can get back now} %end; ! return %routine compile to string(%record(stackfm)%name v) {Delay if possible so S = S.tostring(k) can be optimised in LOAD} %if next = '.' %and control&(check capacity!check unass) = 0 %start v_flag = v_flag ! quick conc %return %else %if const(v) current string(0) = 1; current string(1) = v_disp&255 claim literal(2,0); otype = con; dump string(0) v_base = code; v_disp = litmax %else load(v,any) frame = (frame+1)&(\1) rr(lbr,R0,v_base) rxi(add,R0,0,1<<8) rx(sth,R0,local,frame) v_base = local; v_disp = frame; frame = frame+2 %finish v_type = strings; v_xform = VinS ! (assigned<<8); v_length = 1 %end ! >> CALL << %routine call(%record(stackfm)%name v) %switch b(1:max prim) ! 1 = rem ! 2 = read symbol ! 3 = float ! 4 = to string ! 5 = substring ! 6 = free space ! 7 = SVC; ! *** MOUSES specific *** ! 8 = addr ! 9 = integer ! 10 = short integer ! 11 = byte integer ! 12 = string ! 13 = record ! 14 = real ! 15 = long real ! 16 = length ! 17 = charno ! 18 = int ! 19 = int pt ! 20 = IOCP; ! *** temporary *** ! 21 = type of; ( type of general name parameter ) ! 22 = size of; ( physical length in bytes ) ! 23 = frac pt; ! *** replaces IOCP above in the fullness of time *** %constbyteintegerarray new type(9:17) = integers, short, byte, strings, records, reals, reall, byte, byte %constbytearray New Size(integers:reall) = 4,2,1,8,255,0,4 %integer t,l,p %if v_flag & prim bit # 0 %start; ! built-in primitive l = 0; t = v_header; sym = 0; ! 'sym=0' used as flag elsewhere %if t = 2 %start; ! 'read symbol' v_flag = v_flag & (\prim bit) v_header = 0; ! otherwise looks like "P in R" in "HEADER" q.v. %else drop(v) %finish set lhs -> b(t) b(1): ! REM operate(rem); %return b(2): ! READ SYMBOL call(v) sset(r1,0,VinR,0) %if lhs_type = records %or lhs_type = general %start warn(4) ! *** subsequently, force a call on external routine form of ! read symbol and leave it to generate the error ! *** FRIG *** cload(5,r0); cload(5,r1); perm(signal) set lhs; lhs_type = byte; ! to prevent compiler failing ! *** FRIG *** %finish claim(rhs_base) compile to string(rhs) %if lhs_type = strings assign(1) %return b(3): ! FLOAT float(lhs, anyf); %return b(4): ! TO STRING compile to string(lhs) %return b(8): ! ADDR t = Lhs_Type amap(lhs) %if T = Strings %and Lhs_Form # AVinS %and Lhs_Form # AVinRec %start Load(Lhs, Any) Lhs_Form = VinS Forget Reg(1< map it b(12): ! STRING !!!!! l = 255 b(9):b(10):b(11): ! INTEGER, SHORT, BYTE b(13): ! RECORD b(14):b(15): ! REAL, LONG REAL map it: vmap(lhs); lhs_type = new type(t) lhs_length = new size(Lhs_Type) %return b(19): ! INT PT load(lhs,anyf) p = gpr; hazard(p) rr(fxr,p,lhs_base); claim(p) lhs_base = p; lhs_type = integers; lhs_xform = VinR %return b(18): ! INT p = intfn; ! perm routine t = integers; ! resulting type l = R1; ! result register -> PERM1823 b(23): ! FRAC PT p = frac part t = reall l = FR2 PERM1823: load(lhs,fr2); release(fr2) perm(p) claim(l); ! result register set lhs lhs_base = l; lhs_xform = VinR; lhs_type = t %return b(5): ! substring(S,from,to) load(lhs,r3); drop(lhs); stp = stp-1 set both; stp = stp-2 load(lhs,r1); load(rhs,r2); drop(lhs); drop(rhs) release(r1); release(r2); release(r3) perm(substr); claim(r1) sset(r1,0,v in s,0); rhs_type = strings %return b(21): ! type of(..) b(22): ! size of(..) %if lhs_type # general %start; ! type explicitly specified %if t = 21 %start; ! type of p = gen map(lhs_type) %else p = lhs_length; p = p+1 %if lhs_type = strings %finish release(lhs_base) lhs_type = integers; lhs_form = constant lhs_base = 0; lhs_disp = p %else lhs_disp = lhs_disp + reglen; ! reference property-word lhs_xform = (assigned<<8) ! V in S; lhs_type = integers %if t = 21 %start; ! type of cstack(15); operate(and) %else; ! size of cstack(4); operate(rsh) %finish %finish %return b(6): ! free space perm(freesp); claim(r1) sset(r1,0,VinR,0) %return b(7): ! SVC (MOUSES SPECIFIC) hazard(p) %for p = fr0,1,fr14 set both; stp = stp-2 load(lhs,any) %unless const(lhs); address(rhs,-1) rx(lme,fr0,rhs_base,rhs_disp); claim(rhs_base) rx(svc,r0,lhs_base,lhs_disp) rx(stme,fr0,rhs_base,rhs_disp) drop(lhs); drop(rhs) forget reg(-1) %return b(20): ! IOCP *** temporary *** load(lhs,r4); ! required function release(r4); drop(lhs); stp = stp-1 perm(iocp) %return %finish ! -- normal routine calls -- wdisp = (wdisp+align)&(\align); !keep WSP aligned hazard all %if V_Flag&Assigned = 0 {beware - it returns} %if v_base # 0 %start; ! non-local %if v_base # gla %start t = new tag; define reference(t, r ref) rx(la, link, code, 0) %finish rx(STM,p2,wsp,wdisp) rxi(ADD,wsp,0,wdisp) %if wdisp # 0 %if v_base = gla %start; ! external rx(lm,gla,gla,v_disp) rr(bal, link, link) %else; ! procedure-as-parameter quick load(r2, VinS, v_base, v_disp); forget reg(1<> COMPILER OP << !***** RE=ORGANISE 'call', 'prim' and this routine ***** %routine compiler op(%integer n) %record(stackfm)%name p p == descriptor; stp = stp-1 {DESCRIPTOR increments it!!} p_flag= prim bit; p_header = n abort(m'CMOP') %unless 0 < n <= max prim call(p) %end ! >> COMPILE FOR << %routine compile for %record(stackfm)%name cv, iv, inc, fv %integer lab, safe, n, reg, shadow %routine stab(%record(stackfm)%name v, %integer type) %integer t,r %return %if const(v) load(v,any); r = v_base t = temp v_base = local; v_disp = t v_type = type; v_xform = (assigned<<8) ! V in S rx(ST,r,local,t); release(r) associate(v,r) %if control & suppress = 0 %end %routine set(%record(stackfm)%name v,%integer reg) %record(stackfm)%name r sstack(v); r == stacked(stp)_v lrd(r,reg) stp = stp-1 %end cv == stacked(stp-3)_v inc == stacked(stp-2)_v fv == stacked(stp-1)_v lab = tag abort(m'FOR1') %if for stp = max cycle for stp = for stp + 1; for == for stk(for stp) n = next temp; ! remember current point in temp stack shadow = -1; shadow = temp %if control & check for # 0 stab(fv,integers); stab(inc,integers) for_temp base = temp base %if n # next temp %start; ! protect shadow, FV, INC ? temp base = new temp %finish safe = 0 sstack(inc); operate(sub) iv == stacked(stp)_v; ! iv = iv - inc %if cv_form # v in s %or activity(cv_base) >= 0 %start n = cv_type amap(cv) stab(cv, n) cv_form = a in s %finish stp = stp-4 %if const(fv) %and const(iv) %and const(inc) %start %if inc_disp # 0 %start n = fv_disp-iv_disp %if n !! inc_disp >= 0 %and (n//inc_disp)*inc_disp = n %start safe = 1 %finish %finish %if safe = 0 %start warn(2); ! constant faulty %for parameters %else safe = fv_disp - iv_disp; ! null cycle ? %finish %finish reg = iv_base %if reg <= r2 %start reg = gpr {**cannot return r0,r1,r2} %else reg = any %finish load(iv,reg); reg = iv_base %if safe = 0 %and control & check for # 0 %start set(iv,r0); claim(reg) set(fv,r1); set(inc,r2) perm(fchk1); ! Check %for parameters before entry %finish %if safe = 0 %start; ! non-constant or null cycle sstack(cv); sstack(iv); assign(1); claim(reg) for_initial = for lab base + for stp jump to(for_initial,jump,redefine old) %finish define label(lab); trace flag = control&trace sstack(cv) sstack(iv); sstack(inc); operate(add); ! CV + INC drop(iv); drop(inc) set lhs; load(lhs,reg); ! to make sure ASSIGN doesn't use wrong register assign(1) rx(st,reg,local,shadow) %if shadow >= 0 for_lab = lab; for_reg = reg; for_shadow = shadow for_cvbase = cv_base; for_cvdisp = cv_disp for_cvtype = cv_type; for_cvform = cv_xform for_fvbase = fv_base; for_fvdisp = fv_disp drop(cv); drop(fv) %end; ! for %cycle; ! --- main loop --- sym = next; read symbol(next) -> c(sym) c('l'): language mask = tag; %continue; ! Select language dependent options c('O'): abort(m'STK?') %if stp # 0 abort(m'USNG') %unless using_link == null abort(m'CLMD') %if claimed # 0 abort(m'LIT?') %if ca < 0; ! 'select code/literal area' misused wdisp = 0; p disp = 0 next temp = temp base current line = tag %if control&trace # 0 %start %if next = ':' %or next = 'L' %start trace flag = 1 %else %if trace flag # 0 dump trace %finish %finish %continue c('$'): define var; %continue c('b'): pop drop; vub = lhs_disp pop drop; vlb = lhs_disp %continue %routine adump %switch c(integers:8),g(integers:8); ! 8 =REALS+1 !!!!! %constintegerarray low(integers:8) = 0,-32768, 0, 0(*) %constintegerarray high(integers:8) = 0, 65535, 255, 0(*) %integer j %if high(owntype) # 0 %and control & check capacity # 0 %start warn(8) %unless low(owntype) <= ownval <= high(owntype) %finish -> g(owntype) %if otype # con select literal area %if strings # owntype < reals -> c(owntype) g(integers): gword(ownval); %return c(integers): cword(ownval); -> exit c(reals):c(8): g(reals):g(8): j = real constant(1); %return g(byte): gbyte(ownval); %return c(byte): lit byte(ownval); -> exit g(short): gput(ownval); %return c(short): cput(ownval); -> exit c(strings): g(strings): dump string(data size); %return g(records): gput(0) %for j = 1,1,data size>>1 %return c(records): abort(m'ADMP') exit: select code area %end; ! adump c('A'): aparm = tag %if stp # 0 %start decvar_flag = decvar_flag ! assigned; ! explicit initialisation pop drop %if own type >= reals %start rvalue = lhs_disp %if lhs_type < reals ownval = integer(addr(rvalue)) mantissa = integer(addr(rvalue)+4) %else ownval = lhs_disp; ! a string %finish %else; ! initialise to UNASSIGNED pattern %if own type = byte %start own val = x'80' %else %if own type = short own val = x'FFFF8080' %else %if owntype # strings ownval = x'80808080'; mantissa = x'80808080' %else cslen = x'80'; current string(1) = x'80' %finish %finish %if own form = array %or own form = name array %start adump %for j = 1,1,aparm %else %if otype = 0 %start decvar_flag = decvar_flag & (\assigned); ! %const .... %name decvar_disp = ownval; decvar_base = 0 ! %CONSTINTEGERNAME -> INTEGER ! A in S -> V in S, A in REC -> VinREC %if Decvar_Form = VinS %start Decvar_Form = Constant %else Set Diag(0, Ownval) %if Decvar_Form = AinS decvar_form = decvar_form + (v in s - a in s) %finish %else decvar_base = gla; decvar_disp = ga %if otype >= external %start decvar_flag = decvar_flag & (\assigned) external link(data defn,data size,ga) %else %if otype = con ; ! %const %if decvar_type = strings %start claim literal(cslen+1,1) j = litmax; dump string(0) %else %if decvar_type >= reals j = real constant(0); ! ** N.B. %fn + side-effect ** %else abort(m'AM01') %finish decvar_base = code; decvar_disp = j %continue %finish adump %finish %finish %continue c(''''): get string; %continue c('G'): get string alias = "" %for j = 1, 1, cslen %cycle alias = alias.tostring(current string(j)) %repeat pop drop %continue c('N'): cstack(tag<<16!tag); %continue c('D'): get d cstack(0) %and %continue %if rvalue = 0 %continue %if next = 'A' otype = con; ! anonymous %const j = real constant(0); ! N.B. ** %fn + side-effect ** sset(code,j,v in s,0); rhs_type = reals %continue c('n'): j = tag; set lhs vstack( var(lhs_format)_extra - j ) set both; stp = stp-1 %if rhs_form # 15 %start; ! not record format %if lhs_form = v in s %or lhs_form = VinRec %start rhs_disp = lhs_disp + rhs_disp lhs_xform = lhs_form - v in s + rhs_xform %else %if lhs_form = a in rec %start lhs_form = VinRec; lhs_type = integers load(lhs,any) lhs_xform = rhs_xform %else %if lhs_form <= VinR %start lhs_xform = rhs_xform; ! ???? %else lhs_extra = lhs_disp lhs_xform = rhs_xform+3 %finish %finish %finish lhs_disp = rhs_disp lhs_type = rhs_type lhs_rt = rhs_rt lhs_header = rhs_header %finish lhs_length = rhs_length; lhs_format = rhs_format lhs_dim = rhs_dim drop(rhs) %continue c('@'): vstack(tag) %if lhs_flag & proc bit # 0 %and next # 'p' %c %and lhs_flag&prim bit = 0 %start lhs_rt = p disp lhs_header = wdisp w disp = (p disp+align)&(\align) p disp = 0 %finish %continue c('E'): pop lhs; x == lhs load params(x_link) call(x) %if x_type # 0 %and sym # 0 %start; ! fn/map - SYM=0: see 'CALL'!?!?!?!? sstack(x); drop(x); set lhs %if lhs_type >= reals %then opr = fr0 %else opr = r1 lhs_base = opr; lhs_disp = 0 claim(opr) %if lhs_form = VinR %c %and (lhs_type = strings %or lhs_type = records) %start lhs_base = R1; lhs_form = V in S %if next # 'S' %and next # 'p' %and next # '?' %start %if lhs_type = strings %start n = 256; lhs_length = 255 %else n = var(lhs_format)_length %finish pdisp = basic frame %if pdisp = 0 lhs_base = wsp; lhs_disp = pdisp sstack(lhs); ! a copy for 'ASSIGN' below sset(r1,0,V in S,0); ! N.B. sets RHS implicitly %if lhs_type = strings %start rhs_type = strings %else rhs_type = records; rhs_format = lhs_format %finish assign(1) pdisp = pdisp + n; ! protect stacked temporary lhs_type = 0 %if lhs_type = strings %finish %finish %finish %continue c('M'): c('V'): set lhs opr = r1 %if sym = 'V' %start %if gvar_type >= reals %start opr = FR0 %else %if gvar_type = records %and zero(lhs); ! recordfn result = 0 lhs_type = records; lhs_form = V in S lhs_base = wsp; lhs_disp = 0 lhs_format = gvar_format sstack(lhs); ! duplicate cstack(0) assign(1); ! construct zero record set lhs %finish %else amaps(lhs) %finish lrd(lhs,opr); stp = stp-1 %if sym = 'V' %start %if gvar_type = strings %and gvar_length > 0 %start cload(gvar_length,r0) perm(sfcap); ! string function capacity %else %if control & check capacity # 0 %if gvar_type = short %start claim(opr); rr(CHVR,opr,opr) perm(cap16) %else %if gvar_type = byte rxi(TEST,opr,0,\255) perm(cap8) %finish %finish %finish c('R'): return %continue c('K'): ! %false k = 0; -> true false c('T'): ! %true k = -1 true false: cload(k,r1) return %continue c('a'): array ref(0); %continue c('i'): array ref(1); %continue c('.'): operate(conc); %continue c('+'): operate(add); %continue c('\'): k = -1; -> not neg; ! NOT c('U'): k = 0; ! NEG not neg: pop lhs; cstack(k); sstack(lhs); drop(lhs) c('-'): operate(sub); %continue c('!'): operate(or); %continue c('%'): operate(xor); %continue c('&'): operate(and); %continue c('['): operate(lsh); %continue c(']'): operate(rsh); %continue c('*'): operate(mul); %continue c('/'): operate(div); %continue c('Q'): operate(rdiv); %continue c('X'): operate(exp); %continue c('x'): operate(rexp); %continue c('v'): set lhs %if floating(lhs) %start load(lhs,anyf); opr = fpr %else load(lhs,any); opr = gpr %finish pop lhs k = lhs_base load(lhs,opr) n = new tag jump to(n,greater or equal,internal tag) cstack(0); sstack(lhs); drop(lhs) operate(sub) set lhs; load(lhs,k) define tag(n) %continue c('j'): assign(2); %continue c('S'): assign(1); %continue c('Z'): assign(0); %continue c('p'): assign(-1); %continue c('u'): !++ c('q'): !-- %if sym = 'u' %then k = add %else k = sub set both t = lhs_type; j = lhs_length j = j+1 %if t = strings amap(lhs) abort(m'AM05') %if j = 0 %if j = 2 %start cstack(1); j = lsh %else %if j = 4 cstack(2); j = lsh %else cstack(j); j = mul %finish operate(j) operate(k) set lhs vmap(lhs); lhs_type = t %continue c('='): c('k'): opr = 0; -> cond c('#'): c('t'): opr = 1; -> cond c('<'): opr = 2; -> cond c('>'): opr = 3; -> cond c('('): opr = 4; -> cond c(')'): opr = 5; -> cond cond: val = tag jump to(val,opr+invert,redefine old); invert = 0 %continue c('C'): set both t = lhs_type amap(lhs); amap(rhs) %if t = strings %and (lhs_form = V in S %or lhs_form = VinREC %c %or rhs_form = V in S %or rhs_form = VinREC) %start operate(xor) cstack(8); operate(lsh) cstack(0) %finish c('?'): set both compare(lhs,rhs, next); stp = stp-2 drop(lhs); drop(rhs) %continue c('"'): set both; invert = 16 compare(rhs,lhs, next) stp = stp-1; lhs = rhs; drop(rhs) claim(lhs_base) %continue c('r'): resolve(tag); %continue c('_'): uncond jump = 0; mark assigned = 0 forget all v == var(tag); pop drop j = lhs_disp - v_extra; ! this label - lower bound abort(m'AM10') %unless 0 <= j < v_length; ! within vector ? define tag((v_format + j)!x'8000'); ! N.B. marked as a switch defn. %continue c('W'): v == var(tag) %if control & trusted = 0 %start; ! checked switch via PERM pop lhs lrd(lhs,r1) rxi(lw,r2,code,v_disp) perm(swjump) %else cstack(1); operate(lsh); ! subscript X 2 pop lhs k = v_disp+2*2-v_extra*2 %if const(lhs) %start k = k+lhs_disp j = 0 %else load(lhs, Any) j = Lhs_Base %finish lhs_base = code; lhs_index = j; lhs_disp = k lhs_type = short; lhs_form = V in S rxd(LHL,r1,lhs); claim(r1) drop(lhs) rr(ADD,r1,r1); claim(r1) rr(ADD,r1,code) rr(JMP,always,r1) %finish uncond jump = ca %continue c('B'): val = tag %if val # for_lab %start; ! not %for .... %repeat jump to(val,jump,define new) %else sset(for_cvbase,for_cvdisp,for_cvform,0) hazard(for_reg) pop lhs lhs_type = for_cvtype; lhs_flag = lhs_flag ! assigned lrd(lhs,for_reg) %if for_shadow >= 0 %start rx(clw,for_reg,local,for_shadow) perm(fchk2) %finish %if for_initial # 0 %start define label(for_initial); for_initial = 0 %finish %if for_fvbase = 0 %start; ! constant %if for_fvdisp = 0 %start; ! zero claim(for_reg); rr(lw,for_reg,for_reg) %else rxi(clw,for_reg,for_fvbase,for_fvdisp) %finish %else rx(clw,for_reg,for_fvbase,for_fvdisp) %finish jump to(val,not equal,define new) abort(m'AM15') %if next # ':' read symbol(next); define label(tag) %if for_shadow >= 0 %start %if level # 5 %start rx(st,r12,local,for_shadow) %else rx(lw,for_reg,code,unass) rx(st,for_reg,local,for_shadow) forget reg(1<= for lab base jump to(val,jump,redefine old) %continue %integerfn user label(%integer lab) %record(varfm)%name v %if lab > names %start names = lab v == var(lab) v = 0 v_form = pgm label v_disp = new tag %result = -v_disp %finish %result = -var(lab)_disp %end c('J'): jump to(user label(tag),jump,define new) %continue c('L'): define label(user label(tag)) %continue c(':'): j = tag; abort(m'AM30') %if j >= for lab base define label(j); %continue c('f'): compile for; %continue c('w'): mark assigned = 0; machine code; forget reg(-1); %continue c('P'): pop drop; cput(lhs_disp); forget reg(-1) %continue c('y'): ! %diagnose n j = tag diagnose = 0 %if (j>>14)&3 = 2 %start; ! it's for pass 2 diagnose = j&x'3FFF' diagnose = diagnose ! ((-1)<<15) %if diagnose&4 # 0; ! only for speed %else !***** should pass onto next pass ****** %finish %continue c('z'): control = tag; %continue c('m'): j = -1; -> SIGNAL EVENT c('s'): %if control&trace # 0 %start perm(enter trace); cput(0); ! close off user-supplied routine %finish j = 0; -> SIGNAL EVENT c('e'): j = tag SIGNAL EVENT: cstack(0) %while stp < 2 pop lhs; lrd(lhs,r2) pop lhs; lrd(lhs,r1) cload(j,R0) perm(signal) uncond jump = ca %continue c('o'): event_events = tag; ! events trapped read symbol(next); k = tag j = (frame+align)&(\align); frame = j+reglen rx(ST,wsp,local,j); ! for use below jump to(k,jump,redefine old); event_low = j tag; ! skip event body forget all event_label = new tag define tag(event_label); ! entry point rx(LW,wsp,local,j) %continue c('h'): ! compiler op(n) compiler op(tag) %continue c('g'): !array formats c('d'): ! array allocation and dope vector dumping. Allocate = Sym-'g' {0=format} ! GMODE: =0 -> simple array, # 0 -> array-in-record ! When OPT is specified, in-line code is dumped to ! allocate 1-D constant-bounded arrays dim = tag; abort(m'AM35') %unless 0 < dim <= 7 read symbol(next); n = tag %if gmode = 0 %then names = names-n %else parms = parms+n set both dv = 0; ! used as a flag subsequently t = -1 ! **** The test for OPT must come out once this optimisation is ! implemented correctly **** %if control&checkbits=0 %and dim = 1 %and lhs_disp <= rhs_disp+1 %start %if const(rhs) %and const(lhs) %start t = 0; ! candidate for cheap allocation at least %if 0 < data size <= 32767 %c %and -32768 <= lhs_disp <= 32767 %c %and -32768 <= rhs_disp <= 32767 %start dim = dim ! cheap array bit; ! stuffed in below %finish %finish %finish %if gmode # 0 %or t >= 0 %start vlb = lhs_disp; vub = rhs_disp abort(m'AM40') %if vlb > vub+1; ! null array, A(1:0) allowed set dope vector stp = stp-2; drop(lhs); drop(rhs) %if gmode = 0 %start; ! constant-bounded 1-D simple array quick load(R4, AVinS, code, dv); release(R4) vub = (vub+align) & (\align); ! to preserve stack-front alignment %finish %else frame = (frame+align)&(\align); k = frame; Frame = Frame+Reglen quick load(R4, AVinS, local, K); release(R4) stp = 0 %for j = 1,1,dim<<1 %cycle; ! N.B. not changed above on this path stp = stp+1; set lhs claim(r4); lrd(lhs,any) rx(st,lhs_base,r4,frame-k); frame = frame+reglen frame = frame+reglen %if j&1 = 0; ! LEAVE HOLE FOR MULTIPLIER %repeat perm(set dv) cput(dim); cput(data size) stp = 0 %finish %if dv = 0 %start quick load(R2, AVinS, local, frame) release(R2) forget reg(1<Pc(Sym) %if 'A' <= Sym <= 'Z' Abort(M'I ?' - ' '<<8 +Sym<<8) Pc('A'): {Compare} Pc('D'): {Compare records} Pc('K'): {Test set membership} cload(0, R6); claim(R6) set both j = next; readsymbol(next) %if Sym = 'A' %start %if j <= 1 %then k = '=' %else k = '<' compare(lhs, rhs, k) %else %if Sym = 'K' Load(Lhs, Any); Address(Rhs, -1) Rhs_Type = Integers Rxd(Tbt, Lhs_Base, Rhs) Release(Lhs_Base) %else k = next; readsymbol(next) Compare Records(Lhs, Rhs, K) %finish stp = stp-2; drop(lhs); drop(rhs) skip(1, j+invert); ! short forward jump Invert = 0 rxi(ADD, R6, 0, 1); ! reduces to halfword: AIS R6,1 forget reg(1<=} cput(1) %finish Stp = Stp-2 Sset(R6, 0, VinR, 0); Claim(R6) Rxi(Xor, R6, 0, 1) %if Next = 0 {#} Readsymbol(Next) %continue Pc('L'): {Set operation} Pop Lhs; X == Lhs Set Lhs %if Lhs_Type # 0 %start {needs to be made temporary} Pop Lhs Temp Set Sstack(Lhs); Drop(Lhs) Assign(1) Sset(Local, Frame-SetLen, VinS, 0) Rhs_Type = 0 Set Lhs %finish Load(Lhs, R1) Lrd(X, R2) Perm(Set Ops(next)); Readsymbol(Next) %continue Pc('S'): {Swop top of stack elements} Set Both Stacked(Stp-1)_V == RHS Stacked(Stp)_V == LHS %continue Pc('N'): {check not NIL} %if Control&Check Unass # 0 %start Set Lhs; Test Zero(Lhs); Claim(Lhs_Base) RR(Bal, Link, Code) %finish %continue Pc('W'): {Stack WSP} Cstack(0) Rhs_Form = VinR Rhs_Base = Wsp %continue c('~'): ! alternate record format sym = next; read symbol(next) %if sym = 'A' %start; ! alt start decvar == gvar assemble(-2,labs,names) Alt Align = Alt Align!Falign %else %if sym = 'B'; ! alt end -> OUT %else abort(m'AM45') %if sym # 'C'; ! faulty intermediate code max frame = frame %if frame > max frame frame = putative frame base %finish %continue c('{'): gmode = -1 assemble(gtype,labs,names) %continue c('}'): gmode = 0 -> OUT %if amode < 0; ! end of %record %format defn. -> OUT %if gvar_flag & primbit # 0; ! prim routine reference %if names > gstart %start gvar_extra = parms %for j = gstart+1,1,names %cycle ap == var(j) parms = parms-1; fp == var(parms) fp = ap; fp_base = wsp ap_flag = ap_flag & (\p in r) ! assigned %if ap_flag&array bits = 0 %repeat abort(m'AM50') %if parms < names %if ap_type = strings %and ap_xform & (array bits<<8 + 255) = V in S %c %and ap_base # 0 %start gvar_header = ap_disp fp_flag = fp_flag ! P in R; ! mark as 'in-register' param %finish %finish gdisp = -1; ! so locals are properly placed max parm = frame; !start of local space -> OUT %if amode # 0 header(gvar) %continue c('H'): decvar == begin; decvar_disp = new tag otype = 0; spec = 0; potype = 0 %if level # 0 %start; ! not outermost %begin cstack(decvar_disp) pop lhs; lhs_type = 0; call(lhs) %finish block name = "BLOCK"; ! Fix up diagnostic name for "%begin" block assemble(0,labs,names) %continue %repeat; ! --- end of main loop --- ! To catch the sinners!! C(*): abort(m'?? '<<8 ! sym) %routine ALIGN ALTERNATIVES ! Routine to fix up alternate record definitions - implicit parameters in: ! true frame base, putative frame base, max frame, alt first, alt align %integer n, mod, j %record(varfm)%name v Falign = Alt Align n = putative frame base - true frame base %return %if n = 0 %or alt align = align; ! no padding or fullword req'd %if alt align = 0 %start; ! byte alignment possible mod = n %else; ! at least %short req'd %return %if n = 1; ! can't move it back mod = 2; ! n = 2,3 %finish ! now strip out extra unnecessary alignment %for j = parms,1,alt first %cycle v == var(j) v_disp = v_disp - mod %repeat max frame = max frame - mod %end; ! align alternatives c(';'): %if level # 0 %start %if uncond jump # ca %or (gvar_type = 0 %and control&trusted = 0) %start %if control&trace # 0 %and level = 1 %start perm(enter trace); cput(0); ! close down user-supplied routine %finish return %finish %else; ! level 0: flush literals and gla gbyte(0) %if ga&1 # 0 claim literal(0,0) %if lita&1 # 0 %finish Gvar_Flag = Gvar_Flag!Closed block mark(block end) Reset Optimisation Data OUT: %if amode >= 0 %start; ! end of declarative block activity(local) = 0 %unless local = base5; ! release old base register level = level-1; local = breg(level) %else; ! end of record format defn align alternatives frame = max frame %if max frame > frame %if amode = -2 %start; ! end of alternative only old frame = frame %else frame = (frame+align)&(\align); ! **** temporary **** abort(m'AM55') %unless frame>>16 = 0 {only 16 bits worth} gvar_length <- frame %finish %finish frame = old frame; extra frame = old extra frame uncond jump = old jump; ca = proc ca var diags = old var diags new temp = temp base next temp = old next temp temp base = old temp base last line = -15 %end; ! assemble ! -------- it all starts here --------- control = IMPCOM_flags & 255; ! set compilation options control = control & (\check bits) %if control & trusted # 0; ! force OPT select input(in) select output(object) print symbol(init gla>>1); ! Initial GLA allocation print symbol(init lit>>1); ! specify literal area available to pass 3 claim literal(init lit,align); ! set literal base and initialise pass 3 var(0) = 0; ! for %RECORD(*) . . . . . var(max vars)_Length = SetLen {for sets} parms = max vars cslen == current string(0) activity(wsp) = -1; activity(code) = -1; activity(0) = -1 activity(gla) = -1; activity(link) = -1 %for j = 0,1,max stack-1 %cycle stak(j)_link == stak(j+1) dlist(j)_link == dlist(j+1) %repeat stak(max stack)_link == null dlist(max stack)_link == null desc asl == stak(0); dasl == dlist(0) using_link == null for stk(j) = 0 %for j = 0,1,max cycle for stp = 0; for == for stk(0) read symbol(next); ! Prime SYM/NEXT pair Spec = 0 decvar == begin assemble(2,0,0) close files %signal 15,3 %if faulty # 0 %endofprogram