{$optimize 7} {---------------------------------------------------------------} { } { ORCA Code Generator Interface } { } { This unit serves as the glue code attaching a compiler } { to the code generator. It provides subroutines in a } { format that is convenient for the compiler during } { semantic analysis, and produces intermediate code records } { as output. These intermediate code records are then } { passed on to the code generator for optimization and } { native code generation. } { } { copy 'cgi.comments'} {---------------------------------------------------------------} unit CodeGeneratorInterface; interface {$segment 'CG'} {$LibPrefix '0/obj/'} uses CCommon; const {Error interface: these constants map } {code generator error numbers into the } {numbers used by the compiler's Error } {subroutine. } {--------------------------------------} cge1 = 57; {compiler error} cge2 = 58; {implementation restriction: too many local labels} cge3 = 60; {implementation restriction: string space exhausted} cge4 = 188; {local variable out of range for DP addressing} {65816 native code generation} {----------------------------} {instruction modifier flags} shift8 = 1; {shift operand right 8 bits} shift16 = 2; {shift operand right 16 bits} toolCall = 4; {generate a tool call} stringReference = 8; {generate a string reference} isPrivate = 32; {is the label private?} constantOpnd = 64; {the absolute operand is a constant} localLab = 128; {the operand is a local lab} forFlags = 256; {instruction used for effect on flags only} subtract1 = 512; {subtract 1 from address operand} shiftLeft8 = 1024; {shift operand left 8 bits} labelUsedOnce = 2048; {only one branch targets this label} m_adc_abs = $6D; {op code #s for 65816 instructions} m_adc_dir = $65; m_adc_imm = $69; m_adc_s = $63; m_adc_indl = $67; m_adc_indly = $77; m_and_abs = $2D; m_and_dir = $25; m_and_imm = $29; m_and_s = $23; m_and_indl = $27; m_and_indly = $37; m_asl_a = $0A; m_bcc = $90; m_bcs = $B0; m_beq = $F0; m_bit_imm = $89; m_bmi = $30; m_bne = $D0; m_bpl = $10; m_bra = $80; m_brl = $82; m_bvc = $50; m_bvs = $70; m_clc = $18; m_cmp_abs = $CD; m_cmp_dir = $C5; m_cmp_dirX = $D5; m_cmp_imm = $C9; m_cmp_long = $CF; m_cmp_s = $C3; m_cmp_indl = $C7; m_cmp_indly = $D7; m_cop = $02; m_cpx_abs = 236; m_cpx_dir = 228; m_cpx_imm = 224; m_cpy_imm = $C0; m_dea = 58; m_dec_abs = 206; m_dec_absX = $DE; m_dec_dir = 198; m_dec_dirX = 214; m_dex = 202; m_dey = 136; m_eor_abs = 77; m_eor_dir = 69; m_eor_imm = 73; m_eor_s = 67; m_eor_indl = $47; m_eor_indly = $57; m_ina = 26; m_inc_abs = 238; m_inc_absX = $FE; m_inc_dir = 230; m_inc_dirX = 246; m_inx = 232; m_iny = 200; m_jml = 92; m_jmp_indX = $7C; m_jsl = 34; m_lda_abs = 173; m_lda_absx = 189; m_lda_dir = 165; m_lda_dirx = 181; m_lda_imm = 169; m_lda_indl = 167; m_lda_indly = 183; m_lda_long = 175; m_lda_longx = 191; m_lda_s = 163; m_ldx_abs = 174; m_ldx_dir = 166; m_ldx_imm = 162; m_ldy_abs = 172; m_ldy_absX = 188; m_ldy_dir = 164; m_ldy_dirX = 180; m_ldy_imm = 160; m_lsr_a = 74; m_mvn = 84; m_ora_abs = 13; m_ora_dir = 5; m_ora_dirX = 21; m_ora_imm = 9; m_ora_long = 15; m_ora_longX = 31; m_ora_s = 3; m_ora_indl = $07; m_ora_indly = $17; m_pea = 244; m_pei_dir = 212; m_pha = 72; m_phb = 139; m_phd = 11; m_phx = 218; m_phy = 90; m_php = 8; m_pla = 104; m_plb = 171; m_pld = 43; m_plx = 250; m_ply = 122; m_plp = 40; m_rep = 194; m_rol_a = $2A; m_ror_a = $6A; m_rtl = 107; m_rts = 96; m_sbc_abs = 237; m_sbc_dir = 229; m_sbc_imm = 233; m_sbc_s = 227; m_sbc_indl = $E7; m_sbc_indly = $F7; m_sec = 56; m_sep = 226; m_sta_abs = 141; m_sta_absX = 157; m_sta_dir = 133; m_sta_dirX = 149; m_sta_indl = 135; m_sta_indlY = 151; m_sta_long = 143; m_sta_longX = 159; m_sta_s = 131; m_stx_dir = 134; m_stx_abs = 142; m_sty_abs = 140; m_sty_dir = 132; m_sty_dirX = 148; m_stz_abs = 156; m_stz_absX = 158; m_stz_dir = 100; m_stz_dirX = 116; m_tax = 170; m_tay = 168; m_tcd = 91; m_tcs = 27; m_tdc = 123; m_tsx = $BA; m_txa = 138; m_txs = $9A; m_txy = 155; m_tya = 152; m_tyx = 187; m_tsb_dir = $04; m_tsb_abs = $0C; m_tsc = 59; m_xba = $EB; d_lab = 256; d_end = 257; d_bmov = 258; d_add = 259; d_pin = 260; d_wrd = 261; d_sym = 262; d_cns = 263; d_dcb = 264; d_dcw = 265; d_dcl = 266; max_opcode = 266; asmFlag = $8000; {or'd with opcode to indicate asm code} {Code Generation} {---------------} maxCBuff = 191; {length of constant buffer} {Note: maxlabel is also defined in CCommon.pas} {Note: maxlabel is also defined in CGC.asm} maxLabel = 3275; {max # of internal labels} maxLocalLabel = 512; {max # local variables} maxString = 32760; {max # chars in string space} {size of internal types} {----------------------} cgByteSize = 1; cgWordSize = 2; cgLongSize = 4; cgQuadSize = 8; cgPointerSize = 4; cgRealSize = 4; cgDoubleSize = 8; cgCompSize = 8; cgExtendedSize = 10; type segNameType = packed array[1..10] of char; {segment name} stringSpaceType = packed array[1..maxstring] of char; {string space} {p code} {------} pcodes = {pcode names} (pc_adi,pc_adr,pc_and,pc_dvi,pc_dvr,pc_cnn,pc_cnv,pc_ior,pc_mod,pc_mpi, pc_mpr,pc_ngi,pc_ngr,pc_not,pc_sbi,pc_sbr,pc_sto,pc_dec,dc_loc,pc_ent, pc_fjp,pc_inc,pc_ind,pc_ixa,pc_lao,pc_lca,pc_ldo,pc_mov,pc_ret,pc_sro, pc_xjp,pc_cup,pc_equ,pc_geq,pc_grt,pc_lda,pc_ldc,pc_ldl,pc_leq,pc_les, pc_lil,pc_lld,pc_lli,pc_lod,pc_neq,pc_str,pc_ujp,pc_add,pc_lnm,pc_nam, pc_cui,pc_lad,pc_tjp,dc_lab,pc_usr,pc_umi,pc_udi, pc_uim,dc_enp,pc_stk,dc_glb,dc_dst,dc_str,pc_cop,pc_cpo,pc_tl1, dc_pin,pc_shl,pc_shr,pc_bnd,pc_bor,pc_bxr,pc_bnt,pc_bnl,pc_mpl,pc_dvl, pc_mdl,pc_sll,pc_slr,pc_bal,pc_ngl,pc_adl,pc_sbl,pc_blr,pc_blx, dc_sym,pc_lnd,pc_lor,pc_vsr,pc_uml,pc_udl,pc_ulm,pc_pop,pc_gil, pc_gli,pc_gdl,pc_gld,pc_cpi,pc_tri,pc_lbu,pc_lbf,pc_sbf,pc_cbf,dc_cns, dc_prm,pc_nat,pc_bno,pc_nop,pc_psh,pc_ili,pc_iil,pc_ild,pc_idl, pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq,pc_mpq,pc_umq,pc_dvq, pc_udq,pc_mdq,pc_uqm,pc_slq,pc_sqr,pc_wsr,pc_rbo,pc_fix,pc_rev,pc_ckp, pc_ckn); {intermediate code} {-----------------} icptr = ^intermediate_code; intermediate_code = record {intermediate code record} opcode: pcodes; {operation code} q,r,s: integer; {operands} lab: stringPtr; {named label pointer} next: icptr; {ptr to next statement} left, right: icptr; {leaves for trees} parents: integer; {number of parents} case optype: baseTypeEnum of cgByte, cgUByte, cgWord, cgUWord : (opnd: longint; llab,slab: integer); cgLong, cgULong : (lval: longint); cgQuad, cgUQuad : (qval: longlong); cgReal, cgDouble, cgComp, cgExtended : (rval: extended); cgString : ( case isByteSeq: boolean of false : (str: longStringPtr); true : (data: ptr; len: longint); ); cgVoid, ccPointer : (pval: longint; pstr: longStringPtr); end; codeRef = icptr; {reference to a code location} {basic blocks} {------------} iclist = ^iclistRecord; {used to form lists of records} iclistRecord = record next: iclist; op: icptr; end; blockPtr = ^block; {basic block edges} blockListPtr = ^blockListRecord; {lists of blocks} block = record last, next: blockPtr; {for doubly linked list of blocks} dfn: integer; {depth first order index} visited: boolean; {has this node been visited?} code: icptr; {code in the block} c_in: iclist; {list of reaching definitions} c_out: iclist; {valid definitions on exit} c_gen: iclist; {generated definitions} dom: blockListPtr; {dominators of this block} end; blockListRecord = record {lists of blocks} next, last: blockListPtr; dfn: integer; end; {65816 native code generation} {----------------------------} addressingMode = (implied,immediate, {65816 addressing modes} longabs,longrelative,relative,absolute,direct,gnrLabel,gnrSpace, gnrConstant,genaddress,special,longabsolute); var {current instruction info} {------------------------} isJSL: boolean; {is the current opcode a jsl?} {65816 native code generation} {----------------------------} longA,longI: boolean; {register sizes} {variables used to control the } {quality or characteristics of } {code } {------------------------------} checkNullPointers: boolean; {check for null pointer dereferences?} checkStack: boolean; {check stack for stack errors?} cLineOptimize: boolean; {+o flag set?} code: icptr; {current intermediate code record} codeGeneration: boolean; {is code generation on?} commonSubexpression: boolean; {do common subexpression removal?} currentSegment,defaultSegment: segNameType; {current & default seg names} segmentKind: integer; {kind field of segment (ored with start/data)} defaultSegmentKind: integer; {default segment kind} debugFlag: boolean; {generate debugger calls?} debugStrFlag: boolean; {gsbug/niftylist debug names?} dataBank: boolean; {save, restore data bank?} fastMath: boolean; {do FP math opts that break IEEE rules?} floatCard: integer; {0 -> SANE; 1 -> FPE} floatSlot: integer; {FPE slot} loopOptimizations: boolean; {do loop optimizations?} noroot: boolean; {prevent creation of .root file?} npeephole: boolean; {do native code peephole optimizations?} peephole: boolean; {do peephole optimization?} profileFlag: boolean; {generate profiling code?} rangeCheck: boolean; {generate range checks?} registers: boolean; {do register optimizations?} rtl: boolean; {return with an rtl?} saveStack: boolean; {save, restore caller's stack reg?} smallMemoryModel: boolean; {is the small model in use?} stackSize: integer; {amount of stack space to reserve} strictVararg: boolean; {repair stack around vararg calls?} stringsize: 0..maxstring; {amount of string space left} stringspace: ^stringSpaceType; {string table} symLength: integer; {length of debug symbol table} toolParms: boolean; {generate tool format parameters?} volatile: boolean; {has a volatile qualifier been used?} hasVarargsCall: boolean; {does current function call any varargs fns?} {desk accessory variables} {------------------------} isNewDeskAcc: boolean; {is this a new desk acc?} isClassicDeskAcc: boolean; {is this a classic desk acc?} isCDev: boolean; {is this a control panel device?} isNBA: boolean; {is this a new button action?} isXCMD: boolean; {is this an XCMD?} openName,closeName,actionName, {names of the required procedures} initName: stringPtr; refreshPeriod: integer; {refresh period} eventMask: integer; {event mask} menuLine: pString; {name in menu bar} {DAG construction} {----------------} DAGhead: icPtr; {1st ic in DAG list} DAGblocks: blockPtr; {list of basic blocks} {---------------------------------------------------------------} procedure CodeGenFini; { terminal processing } procedure CodeGenInit (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean); { code generator initialization } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } procedure CodeGenScalarInit; { initialize codegen scalars } {procedure InitWriteCode; {debug} { initialize the intermediate code opcode table } procedure Gen0 (fop: pcodes); { generate an implied operand instruction } { } { parameters: } { fop - operation code } procedure Gen1 (fop: pcodes; fp2: integer); { generate an instruction with one numeric operand } { } { parameters: } { fop - operation code } { fp2 - operand } procedure Gen2 (fop: pcodes; fp1, fp2: integer); { generate an instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } procedure Gen3 (fop: pcodes; fp1, fp2, fp3: integer); { generate an instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - third operand } procedure Gen0Name (fop: pcodes; name: stringPtr); { generate a p-code with a name } { } { parameters: } { fop - operation code } { name - named label } procedure Gen1Name (fop: pcodes; fp1: integer; name: stringPtr); { generate a one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { name - named label } procedure Gen2Name (fop: pcodes; fp1, fp2: integer; name: stringPtr); { generate a two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { name - named label } procedure Gen0tName (fop: pcodes; tp: baseTypeEnum; name: stringPtr); { generate a typed zero operand p-code with a name } { } { parameters: } { fop - operation code } { tp - base type } { name - named label } procedure Gen1tName (fop: pcodes; fp1: integer; tp: baseTypeEnum; name: stringPtr); { generate a typed one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { tp - base type } { name - named label } procedure Gen2tName (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum; name: stringPtr); { generate a typed two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } { name - named label } procedure Gen0t (fop: pcodes; tp: baseTypeEnum); { generate a typed implied operand instruction } { } { parameters: } { fop - operation code } { tp - base type } procedure Gen1t (fop: pcodes; fp1: integer; tp: baseTypeEnum); { generate a typed instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - operand } { tp - base type } procedure Gen2t (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum); { generate a typed instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } procedure Gen3t (fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum); { generate a typed instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - second operand } { tp - base type } procedure GenPS (fop: pcodes; str: stringPtr); { generate an instruction that uses a p-string operand } { } { parameters: } { fop - operation code } { str - pointer to string } procedure GenS (fop: pcodes; str: longstringPtr); { generate an instruction that uses a string operand } { } { parameters: } { fop - operation code } { str - pointer to string } procedure GenBS (fop: pcodes; data: ptr; len: longint); { generate an instruction that uses a byte sequence operand } { } { parameters: } { fop - operation code } { data - pointer to data } { data - length of data } procedure GenL1 (fop: pcodes; lval: longint; fp1: integer); { generate an instruction that uses a longint and an int } { } { parameters: } { lval - longint parameter } { fp1 - integer parameter } procedure GenQ1 (fop: pcodes; qval: longlong; fp1: integer); { generate an instruction that uses a longlong and an int } { } { parameters: } { qval - longlong parameter } { fp1 - integer parameter } procedure GenR1t (fop: pcodes; rval: extended; fp1: integer; tp: baseTypeEnum); { generate an instruction that uses a real and an int } { } { parameters: } { rval - real parameter } { fp1 - integer parameter } { tp - base type } procedure GenLdcLong (lval: longint); { load a long constant } { } { parameters: } { lval - value to load } procedure GenLdcQuad (qval: longlong); { load a long long constant } { } { parameters: } { qval - value to load } procedure GenLdcReal (rval: extended); { load a real constant } { } { parameters: } { rval - value to load } procedure GenTool (fop: pcodes; fp1, fp2: integer; dispatcher: longint); { generate a tool call } { } { parameters: } { fop - operation code } { fp1 - tool number } { fp2 - return size } { dispatcher - tool entry point } function GetCodeLocation: codeRef; { Get a reference to the current location in the generated } { code, suitable to be passed to RemoveCode. } procedure InsertCode (theCode: codeRef); { Insert a section of already-generated code that was } { previously removed with RemoveCode. } { } { parameters: } { theCode - code removed (returned from RemoveCode) } {procedure PrintBlocks (tag: stringPtr; bp: blockPtr); {debug} { print a series of basic blocks } { } { parameters: } { tag - label for lines } { bp - first block to print } {procedure PrintDAG (tag: stringPtr; code: icptr); {debug} { print a DAG } { } { parameters: } { tag - label for lines } { code - first node in DAG } function RemoveCode (start: codeRef): codeRef; { Remove a section of already-generated code, from immediately } { after start up to the latest code generated. Returns the } { code removed, so it may be re-inserted later. } { } { parameters: } { start - location to start removing from } { } { Note: start must be a top-level pcode (not a subexpression). } { Note: The region removed must not include a dc_enp. } function TypeSize (tp: baseTypeEnum): integer; { Find the size, in bytes, of a variable } { } { parameters: } { tp - base type of the variable } {procedure WriteCode (code: icptr); {debug} { print an intermediate code instruction } { } { Parameters: } { code - intermediate code instruction to write } procedure LimitPrecision (var rval: extended; tp: baseTypeEnum); { limit the precision and range of a real value to the type. } { } { parameters: } { rval - real value } { tp - type to limit precision to } {------------------------------------------------------------------------------} implementation {var opt: array[pcodes] of packed array[1..3] of char; {debug} {Imported from CGC.pas:} function Calloc (bytes: integer): ptr; extern; { Allocate memory from a pool and clear it. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } procedure Error (err: integer); extern; {in scanner.pas} { flag an error } { } { err - error number } function Malloc (bytes: integer): ptr; extern; { Allocate memory from a pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } procedure InitLabels; extern; { initialize the labels array for a procedure } {Imported from ObjOut.pas:} procedure CloseObj; extern; { close the current obj file } {Imported from Native.pas:} procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean); extern; { Set up the object file } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } {Imported from DAG.pas:} procedure DAG (code: icptr); extern; { place an op code in a DAG or tree } { } { parameters: } { code - opcode } {------------------------------------------------------------------------------} { copy 'cgi.debug'} {debug} procedure CodeGenInit {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean}; { code generator initialization } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } begin {CodeGenInit} {initialize the debug tables {debug} {InitWriteCode; {debug} {initialize the label table} InitLabels; codeGeneration := true; {turn on code generation} {set up the DAG variables} DAGhead := nil; {no ics in DAG list} InitFile(keepName, keepFlag, partial); {open the interface file} end; {CodeGenInit} procedure CodeGenFini; { terminal processing } begin {CodeGenFini} CloseObj; {close the open object file} end; {CodeGenFini} procedure CodeGenScalarInit; { initialize codegen scalars } begin {CodeGenScalarInit} isJSL := false; {the current opcode is not a jsl} isNewDeskAcc := false; {assume a normal program} isCDev := false; isClassicDeskAcc := false; isNBA := false; isXCMD := false; codeGeneration := false; {code generation is not turned on yet} currentSegment := ' '; {start with the blank segment} defaultSegment := ' '; segmentKind := 0; {default to static code segments} defaultSegmentKind := 0; smallMemoryModel := true; {small memory model} dataBank := false; {don't save/restore data bank} strictVararg := {save/restore caller's stack around vararg} (not cLineOptimize) or strictMode; saveStack := not cLineOptimize; {save/restore caller's stack reg} checkStack := false; {don't check stack for stack errors} stackSize := 0; {default to the launcher's stack size} toolParms := false; {generate tool format parameters?} noroot := false; {create a .root segment} rtl := false; {return with a ~QUIT} floatCard := 0; {use SANE} floatSlot := 0; {default to slot 0} stringSize := 0; {no strings, yet} rangeCheck := false; {don't generate range checks} profileFlag := false; {don't generate profiling code} debugFlag := false; {don't generate debug code} debugStrFlag := false; {don't generate gsbug debug strings} traceBack := false; {don't generate traceback code} checkNullPointers := false; {don't check null pointers} volatile := false; {no volatile qualifiers found} registers := cLineOptimize; {don't do register optimizations} peepHole := cLineOptimize; {not doing peephole optimization (yet)} npeepHole := cLineOptimize; fastMath := cLineOptimize; commonSubexpression := cLineOptimize; {not doing common subexpression elimination} loopOptimizations := cLineOptimize; {not doing loop optimizations, yet} {allocate string space} new(stringspace); {allocate the initial p-code} code := pointer(Calloc(sizeof(intermediate_code))); code^.optype := cgWord; end; {CodeGenScalarInit} procedure Gen0 {fop: pcodes}; { generate an implied operand instruction } { } { parameters: } { fop - operation code } begin {Gen0} if codeGeneration then begin {generate the intermediate code instruction} code^.opcode := fop; { if printSymbols then {debug} { WriteCode(code); {debug} DAG(code); {generate the code} {initialize volatile variables for next intermediate code} code := pointer(Calloc(sizeof(intermediate_code))); {code^.lab := nil;} code^.optype := cgWord; end; {if} end; {Gen0} procedure Gen1 {fop: pcodes; fp2: integer}; { generate an instruction with one numeric operand } { } { parameters: } { fop - operation code } { fp2 - operand } begin {Gen1} if codeGeneration then begin if fop = pc_ret then code^.optype := cgVoid; code^.q := fp2; Gen0(fop); end; {if} end; {Gen1} procedure Gen2 {fop: pcodes; fp1, fp2: integer}; { generate an instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } label 1; var lcode: icptr; {local copy of code} begin {Gen2} if codeGeneration then begin lcode := code; case fop of pc_lnm,pc_tl1,pc_lda,dc_loc,pc_mov: begin lcode^.r := fp1; lcode^.q := fp2; end; pc_cnn,pc_cnv: if (fp1 = fp2) and not (baseTypeEnum(fp2) in [cgReal,cgDouble,cgComp]) then goto 1 else if (baseTypeEnum(fp1) in [cgReal,cgDouble,cgComp,cgExtended]) and (baseTypeEnum(fp2) = cgExtended) then goto 1 else if (baseTypeEnum(fp1) in [cgUByte,cgWord,cgUWord]) and (baseTypeEnum(fp2) in [cgWord,cgUWord]) then goto 1 else if (baseTypeEnum(fp1) in [cgUByte]) and (baseTypeEnum(fp2) in [cgByte,cgUByte]) then goto 1 else if (baseTypeEnum(fp1) = cgByte) and (baseTypeEnum(fp2) = cgUByte) then lcode^.q := (ord(cgWord) << 4) | ord(cgUByte) else lcode^.q := (fp1 << 4) | fp2; otherwise: Error(cge1); end; {case} Gen0(fop); end; {if} 1: end; {Gen2} procedure Gen3 {fop: pcodes; fp1, fp2, fp3: integer}; { generate an instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - third operand } var lcode: icptr; {local copy of code} begin {Gen3} if codeGeneration then begin lcode := code; lcode^.s := fp1; lcode^.q := fp2; lcode^.r := fp3; Gen0(fop); end; {if} end; {Gen3} procedure Gen0Name {fop: pcodes; name: stringPtr}; { generate a p-code with a name } { } { parameters: } { fop - operation code } { name - named label } begin {Gen0Name} if codeGeneration then begin code^.lab := name; Gen0(fop); end; {if} end; {Gen0Name} procedure Gen1Name {fop: pcodes; fp1: integer; name: stringPtr}; { generate a one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { name - named label } var lcode: icptr; {local copy of code} begin {Gen1Name} if codeGeneration then begin lcode := code; lcode^.q := fp1; lcode^.lab := name; Gen0(fop); end; {if} end; {Gen1Name} procedure Gen2Name {fop: pcodes; fp1, fp2: integer; name: stringPtr}; { generate a two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { name - named label } var lcode: icptr; {local copy of code} begin {Gen2Name} if codeGeneration then begin lcode := code; lcode^.q := fp2; lcode^.r := fp1; lcode^.lab := name; Gen0(fop); end; {if} end; {Gen2Name} procedure Gen0tName {fop: pcodes; tp: baseTypeEnum; name: stringPtr}; { generate a typed zero operand p-code with a name } { } { parameters: } { fop - operation code } { tp - base type } { name - named label } var lcode: icptr; {local copy of code} begin {Gen0tName} if codeGeneration then begin lcode := code; lcode^.lab := name; lcode^.optype := tp; Gen0(fop); end; {if} end; {Gen0tName} procedure Gen1tName {fop: pcodes; fp1: integer; tp: baseTypeEnum; name: stringPtr}; { generate a typed one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { tp - base type } { name - named label } var lcode: icptr; {local copy of code} begin {Gen1tName} if codeGeneration then begin lcode := code; lcode^.q := fp1; lcode^.lab := name; lcode^.optype := tp; Gen0(fop); end; {if} end; {Gen1tName} procedure Gen2tName {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum; name: stringPtr}; { generate a typed two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } { name - named label } var lcode: icptr; {local copy of code} begin {Gen2tName} if codeGeneration then begin lcode := code; lcode^.r := fp1; lcode^.q := fp2; lcode^.lab := name; lcode^.optype := tp; Gen0(fop); end; {if} end; {Gen2tName} procedure Gen0t {fop: pcodes; tp: baseTypeEnum}; { generate a typed implied operand instruction } { } { parameters: } { fop - operation code } { tp - base type } begin {Gen0t} if codeGeneration then begin code^.optype := tp; Gen0(fop); end; {if} end; {Gen0t} procedure Gen1t {fop: pcodes; fp1: integer; tp: baseTypeEnum}; { generate a typed instruction with one numeric operand } { } { parameters: } { fop - operation code } { fp1 - operand } { tp - base type } var lcode: icptr; {local copy of code} begin {Gen1t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.q := fp1; Gen0(fop); end; {if} end; {Gen1t} procedure Gen2t {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum}; { generate a typed instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } var lcode: icptr; {local copy of code} begin {Gen2t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.r := fp1; lcode^.q := fp2; Gen0(fop); end; {if} end; {Gen2t} procedure Gen3t {fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum}; { generate a typed instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - second operand } { tp - base type } var lcode: icptr; {local copy of code} begin {Gen3t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.s := fp1; lcode^.q := fp2; lcode^.r := fp3; Gen0(fop); end; {if} end; {Gen3t} procedure GenPS {fop: pcodes; str: stringPtr}; { generate an instruction that uses a p-string operand } { } { parameters: } { fop - operation code } { str - pointer to string } var lcode: icptr; {local copy of code} begin {GenPS} if codeGeneration then begin lcode := code; lcode^.optype := cgString; lcode^.q := length(str^); lcode^.str := pointer(ord4(str)-1); Gen0(fop); end; {if} end; {GenPS} procedure GenS {fop: pcodes; str: longstringPtr}; { generate an instruction that uses a string operand } { } { parameters: } { fop - operation code } { str - pointer to string } var lcode: icptr; {local copy of code} begin {GenS} if codeGeneration then begin lcode := code; lcode^.optype := cgString; lcode^.q := str^.length; lcode^.str := str; Gen0(fop); end; {if} end; {GenS} procedure GenBS {fop: pcodes; data: ptr; len: longint}; { generate an instruction that uses a byte sequence operand } { } { parameters: } { fop - operation code } { data - pointer to data } { len - length of data } var lcode: icptr; {local copy of code} begin {GenBS} if codeGeneration then begin lcode := code; lcode^.optype := cgString; lcode^.isByteSeq := true; lcode^.data := data; lcode^.len := len; Gen0(fop); end; {if} end; {GenBS} procedure GenL1 {fop: pcodes; lval: longint; fp1: integer}; { generate an instruction that uses a longint and an int } { } { parameters: } { lval - longint parameter } { fp1 - integer parameter } var lcode: icptr; {local copy of code} begin {GenL1} if codeGeneration then begin lcode := code; lcode^.optype := cgLong; lcode^.lval := lval; lcode^.q := fp1; Gen0(fop); end; {if} end; {GenL1} procedure GenQ1 {fop: pcodes; qval: longlong; fp1: integer}; { generate an instruction that uses a longlong and an int } { } { parameters: } { qval - longlong parameter } { fp1 - integer parameter } var lcode: icptr; {local copy of code} begin {GenQ1} if codeGeneration then begin lcode := code; lcode^.optype := cgQuad; lcode^.qval := qval; lcode^.q := fp1; Gen0(fop); end; {if} end; {GenQ1} procedure GenR1t {fop: pcodes; rval: extended; fp1: integer; tp: baseTypeEnum}; { generate an instruction that uses a real and an int } { } { parameters: } { rval - real parameter } { fp1 - integer parameter } { tp - base type } var lcode: icptr; {local copy of code} begin {GenR1t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.rval := rval; lcode^.q := fp1; Gen0(fop); end; {if} end; {GenR1t} procedure GenLdcLong {lval: longint}; { load a long constant } { } { parameters: } { lval - value to load } var lcode: icptr; {local copy of code} begin {GenLdcLong} if codeGeneration then begin lcode := code; lcode^.optype := cgLong; lcode^.lval := lval; Gen0(pc_ldc); end; {if} end; {GenLdcLong} procedure GenLdcQuad {qval: longlong}; { load a long long constant } { } { parameters: } { qval - value to load } var lcode: icptr; {local copy of code} begin {GenLdcQuad} if codeGeneration then begin lcode := code; lcode^.optype := cgQuad; lcode^.qval := qval; Gen0(pc_ldc); end; {if} end; {GenLdcQuad} procedure GenTool {fop: pcodes; fp1, fp2: integer; dispatcher: longint}; { generate a tool call } { } { parameters: } { fop - operation code } { fp1 - tool number } { fp2 - return size } { dispatcher - tool entry point } var lcode: icptr; {local copy of code} begin {GenTool} if codeGeneration then begin lcode := code; lcode^.q := fp1; lcode^.r := fp2; lcode^.optype := cgLong; lcode^.lval := dispatcher; Gen0(fop); end; {if} end; {GenTool} procedure GenLdcReal {rval: extended}; { load a real constant } { } { parameters: } { rval - value to load } var lcode: icptr; {local copy of code} begin {GenLdcReal} if codeGeneration then begin lcode := code; lcode^.optype := cgReal; lcode^.rval := rval; Gen0(pc_ldc); end; {if} end; {GenLdcReal} function GetCodeLocation{: codeRef}; { Get a reference to the current location in the generated } { code, suitable to be passed to RemoveCode. } begin {GetCodeLocation} GetCodeLocation := DAGhead; end {GetCodeLocation}; procedure InsertCode {theCode: codeRef}; { Insert a section of already-generated code that was } { previously removed with RemoveCode. } { } { parameters: } { theCode - code removed (returned from RemoveCode) } var lcode: icptr; begin {InsertCode} if theCode <> nil then if codeGeneration then begin lcode := theCode; { PrintDAG(@'Inserting: ', lcode); {debug} while lcode^.next <> nil do lcode := lcode^.next; lcode^.next := DAGhead; DAGhead := theCode; end; {if} end; {InsertCode} function RemoveCode {start: codeRef): codeRef}; { Remove a section of already-generated code, from immediately } { after start up to the latest code generated. Returns the } { code removed, so it may be re-inserted later. } { } { parameters: } { start - location to start removing from } { } { Note: start must be a top-level pcode (not a subexpression). } { Note: The region removed must not include a dc_enp. } var lcode: icptr; begin {RemoveCode} if start = DAGhead then RemoveCode := nil else begin RemoveCode := DAGhead; if codeGeneration then begin lcode := DAGhead; while (lcode^.next <> start) and (lcode^.next <> nil) do lcode := lcode^.next; if lcode^.next = nil then Error(cge1); lcode^.next := nil; { PrintDAG(@'Removing: ', DAGhead); {debug} DAGhead := start; end; {if} end; {else} end; {RemoveCode} function TypeSize {tp: baseTypeEnum): integer}; { Find the size, in bytes, of a variable } { } { parameters: } { tp - base type of the variable } begin {TypeSize} case tp of cgByte,cgUByte: TypeSize := cgByteSize; cgWord,cgUWord: TypeSize := cgWordSize; cgLong,cgULong: TypeSize := cgLongSize; cgQuad,cgUQuad: TypeSize := cgQuadSize; cgReal: TypeSize := cgRealSize; cgDouble: TypeSize := cgDoubleSize; cgComp: TypeSize := cgCompSize; cgExtended: TypeSize := cgExtendedSize; cgString: TypeSize := cgByteSize; cgVoid,ccPointer: TypeSize := cgLongSize; end; {case} end; {TypeSize} procedure LimitPrecision {rval: var extended; tp: baseTypeEnum}; { limit the precision and range of a real value to the type. } { } { parameters: } { rval - real value } { tp - type to limit precision to } var d: double; s: real; c: comp; begin {LimitPrecision} case tp of cgReal: begin s := rval; rval := s; end; cgDouble: begin d := rval; rval := d; end; cgComp: if rval < 0.0 then begin {work around SANE comp conversion bug} c := -rval; rval := -c; end {if} else begin c := rval; rval := c; end; {else} cgExtended: ; end; {case} end; {LimitPrecision} end.