From 085cd7eb1b42cb058353f11d2a28097a4e5f09b6 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 29 Jan 2021 20:50:21 -0600 Subject: [PATCH 01/68] Initial code to recognize 'long long' as a type. --- CCommon.pas | 7 +++++-- CGI.Debug | 2 ++ CGI.pas | 4 ++++ Header.pas | 2 +- Parser.pas | 27 ++++++++++++++++++++------- Scanner.pas | 4 ++-- Symbol.pas | 25 +++++++++++++++++++++++-- 7 files changed, 57 insertions(+), 14 deletions(-) diff --git a/CCommon.pas b/CCommon.pas index 5eb8990..2c27e7f 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -114,6 +114,7 @@ type {Misc.} {-----} long = record lsw,msw: integer; end; {for extracting words from longints} + longlong = record low32,high32: longint; end; {64-bit integer representation} cString = packed array [1..256] of char; {null terminated string} cStringPtr = ^cString; @@ -146,7 +147,7 @@ type { the compiler. Any values whose type is cc must be resolved to one } { of the cg types before the code generator is called. } - baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong, + baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, cgReal,cgDouble,cgComp,cgExtended,cgString, cgVoid,ccPointer); @@ -157,7 +158,7 @@ type cTypeEnum = (ctChar, ctSChar, ctUChar, ctShort, ctUShort, ctInt, ctUInt, ctLong, ctULong, ctFloat, ctDouble, ctLongDouble, ctComp, - ctVoid, ctInt32, ctUInt32, ctBool); + ctVoid, ctInt32, ctUInt32, ctBool, ctLongLong, ctULongLong); {tokens} {------} @@ -316,6 +317,8 @@ type cgUWord, cgLong, cgULong : (iVal: longint); + cgQuad, + cgUQuad : (qVal: longlong); cgString : (sVal: longstringPtr); cgReal, cgDouble, diff --git a/CGI.Debug b/CGI.Debug index 82fcc08..dffc2ce 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -239,6 +239,8 @@ var cgUWord: write('u'); cgLong: write('l'); cgULong: write('ul'); + cgQuad: write('q'); + cgUQuad: write('uq'); cgReal: write('r'); cgDouble: write('d'); cgComp: write('c'); diff --git a/CGI.pas b/CGI.pas index 3a4b295..6dac8c6 100644 --- a/CGI.pas +++ b/CGI.pas @@ -204,6 +204,7 @@ const cgByteSize = 1; cgWordSize = 2; cgLongSize = 4; + cgQuadSize = 8; cgPointerSize = 4; cgRealSize = 4; cgDoubleSize = 8; @@ -246,6 +247,8 @@ type cgUWord : (opnd: longint; llab,slab: integer); cgLong, cgULong : (lval: longint); + cgQuad, + cgUQuad : (qval: longlong); cgReal, cgDouble, cgComp, @@ -1291,6 +1294,7 @@ 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; diff --git a/Header.pas b/Header.pas index 065cc2c..bcdd8f4 100644 --- a/Header.pas +++ b/Header.pas @@ -18,7 +18,7 @@ uses CCommon, MM, Scanner, Symbol, CGI; {$segment 'SCANNER'} const - symFileVersion = 8; {version number of .sym file format} + symFileVersion = 9; {version number of .sym file format} var inhibitHeader: boolean; {should .sym includes be blocked?} diff --git a/Parser.pas b/Parser.pas index ee208c3..3e4ccca 100644 --- a/Parser.pas +++ b/Parser.pas @@ -2602,6 +2602,8 @@ var mySkipDeclarator: boolean; {value of skipDeclarator to generate} myTypeSpec: typePtr; {value of typeSpec to generate} myDeclarationModifiers: tokenSet; {all modifiers in this declaration} + + isLongLong: boolean; {is this a "long long" type?} procedure FieldList (tp: typePtr; kind: typeKind); @@ -2799,11 +2801,19 @@ var else if (typeSpecifiers = [longsy]) or (typeSpecifiers = [signedsy,longsy]) or (typeSpecifiers = [longsy,intsy]) - or (typeSpecifiers = [signedsy,longsy,intsy]) then - myTypeSpec := longPtr + or (typeSpecifiers = [signedsy,longsy,intsy]) then begin + if isLongLong then + myTypeSpec := longLongPtr + else + myTypeSpec := longPtr; + end {else if} else if (typeSpecifiers = [unsignedsy,longsy]) - or (typeSpecifiers = [unsignedsy,longsy,intsy]) then - myTypeSpec := uLongPtr + or (typeSpecifiers = [unsignedsy,longsy,intsy]) then begin + if isLongLong then + myTypeSpec := uLongLongPtr + else + myTypeSpec := uLongPtr; + end {else if} else if typeSpecifiers = [floatsy] then myTypeSpec := floatPtr else if typeSpecifiers = [doublesy] then @@ -2829,6 +2839,7 @@ myDeclarationModifiers := []; typeSpecifiers := []; typeDone := false; isConstant := false; +isLongLong := false; while token.kind in allowedTokens do begin case token.kind of {storage class specifiers} @@ -2918,9 +2929,11 @@ while token.kind in allowedTokens do begin if typeDone then UnexpectedTokenError(expectedNext) else if token.kind in typeSpecifiers then begin - if (token.kind = longsy) - and (typeSpecifiers <= [signedsy,unsignedsy,longsy,intsy]) then - Error(134) + if (token.kind = longsy) and + ((myTypeSpec = longPtr) or (myTypeSpec = uLongPtr)) then begin + isLongLong := true; + ResolveType; + end else UnexpectedTokenError(expectedNext); end {if} diff --git a/Scanner.pas b/Scanner.pas index fd28a16..c2dd5ad 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -663,8 +663,8 @@ if list or (numErr <> 0) then begin 131: msg := @'numeric constant is too long'; 132: msg := @'static assertion failed'; 133: msg := @'incomplete or function types may not be used here'; - 134: msg := @'''long long'' types are not supported by ORCA/C'; - 135: msg := @'the type _Bool is not supported by ORCA/C'; + {134: msg := @'''long long'' types are not supported by ORCA/C';} + {135: msg := @'the type _Bool is not supported by ORCA/C';} 136: msg := @'complex or imaginary types are not supported by ORCA/C'; 137: msg := @'atomic types are not supported by ORCA/C'; 138: msg := @'unsupported alignment'; diff --git a/Symbol.pas b/Symbol.pas index 2694d2b..5cc2c1a 100644 --- a/Symbol.pas +++ b/Symbol.pas @@ -36,6 +36,8 @@ { uInt32Ptr - pointer to the base type for 32-bit unsigned int } { longPtr - pointer to the base type for long } { uLongPtr - pointer to the base type for unsigned long } +{ longLongPtr - pointer to the base type for long long } +{ uLongLongPtr - pointer to base type for unsigned long long } { floatPtr - pointer to the base type for float } { doublePtr - pointer to the base type for double } { compPtr - pointer to the base type for comp } @@ -77,8 +79,9 @@ var {base types} charPtr,sCharPtr,uCharPtr,shortPtr,uShortPtr,intPtr,uIntPtr,int32Ptr, - uInt32Ptr,longPtr,uLongPtr,floatPtr,doublePtr,compPtr,extendedPtr, - boolPtr,stringTypePtr,voidPtr,voidPtrPtr,defaultStruct: typePtr; + uInt32Ptr,longPtr,uLongPtr,longLongPtr,uLongLongPtr,boolPtr, + floatPtr,doublePtr,compPtr,extendedPtr,stringTypePtr,voidPtr, + voidPtrPtr,defaultStruct: typePtr; {---------------------------------------------------------------} @@ -1306,6 +1309,24 @@ with uLongPtr^ do begin baseType := cgULong; cType := ctULong; end; {with} +new(longLongPtr); {long long} +with longLongPtr^ do begin + size := cgQuadSize; + saveDisp := 0; + isConstant := false; + kind := scalarType; + baseType := cgQuad; + cType := ctLongLong; + end; {with} +new(uLongLongPtr); {unsigned long} +with uLongLongPtr^ do begin + size := cgQuadSize; + saveDisp := 0; + isConstant := false; + kind := scalarType; + baseType := cgUQuad; + cType := ctULongLong; + end; {with} new(floatPtr); {real} with floatPtr^ do begin size := cgRealSize; From fa835aca43790dcbf9e73625a91452d044185e16 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 29 Jan 2021 23:11:08 -0600 Subject: [PATCH 02/68] Implement basic load/store ops for long long. The following intermediate codes should now work: pc_lod pc_pop pc_str pc_cop pc_sro pc_cpo --- DAG.pas | 4 ++ Gen.pas | 135 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 139 insertions(+) diff --git a/DAG.pas b/DAG.pas index a6a3be5..7601ca3 100644 --- a/DAG.pas +++ b/DAG.pas @@ -166,6 +166,10 @@ else if (op1 <> nil) and (op2 <> nil) then cgLong, cgULong: if op1^.lval = op2^.lval then CodesMatch := true; + cgQuad, cgUQuad: + if op1^.qval.low32 = op2^.qval.low32 then + if op1^.qval.high32 = op2^.qval.high32 then + CodesMatch := true; cgReal, cgDouble, cgComp, cgExtended: if op1^.rval = op2^.rval then CodesMatch := true; diff --git a/Gen.pas b/Gen.pas index 4d808ef..f698f26 100644 --- a/Gen.pas +++ b/Gen.pas @@ -3209,6 +3209,42 @@ case optype of end; {case} end; {else} end; {case CGLong, cgULong} + + cgQuad, cgUQuad: begin + GenTree(op^.left); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 1, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q, lab, 0) + else + GenNative(m_sta_long, longabsolute, q, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 3, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+2, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+2, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 5, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+4, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+4, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 7, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+6, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+6, lab, 0); + end; {case cgQuad, cgUQuad} end; {case} end; {GenSroCpo} @@ -3809,6 +3845,55 @@ case optype of end; {else} end; + cgQuad, cgUQuad: begin + GenTree(op^.left); + if disp < 250 then begin + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_dir, direct, disp, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_dir, direct, disp+2, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_dir, direct, disp+4, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_dir, direct, disp+6, nil, 0); + end {else if} + else begin + GenNative(m_ldx_imm, immediate, disp, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_dirX, direct, 0, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_dirX, direct, 2, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_dirX, direct, 4, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_dirX, direct, 6, nil, 0); + end; {else} + end; + otherwise: ; end; {case} @@ -4579,6 +4664,29 @@ procedure GenTree {op: icptr}; end; {else} end; {case cgLong,cgULong} + cgQuad, cgUQuad: begin + if smallMemoryModel then begin + GenNative(m_lda_abs, absolute, op^.q+6, op^.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_abs, absolute, op^.q+4, op^.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_abs, absolute, op^.q+2, op^.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0); + GenImplied(m_pha); + end {if} + else begin + GenNative(m_lda_long, longabsolute, op^.q+6, op^.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_long, longabsolute, op^.q+4, op^.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0); + GenImplied(m_pha); + end; {else} + end; {case cgQuad,cgUQuad} + otherwise: Error(cge1); end; {case} @@ -4632,6 +4740,26 @@ procedure GenTree {op: icptr}; GenCall(71); end; + cgQuad, cgUQuad: begin + if disp >= 250 then begin + GenNative(m_ldx_imm, immediate, disp, nil, 0); + GenNative(m_lda_dirx, direct, 6, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirx, direct, 4, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirx, direct, 2, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirx, direct, 0, nil, 0); + GenImplied(m_pha); + end {if} + else begin + GenNative(m_pei_dir, direct, disp+6, nil, 0); + GenNative(m_pei_dir, direct, disp+4, nil, 0); + GenNative(m_pei_dir, direct, disp+2, nil, 0); + GenNative(m_pei_dir, direct, disp, nil, 0); + end; {else} + end; + cgLong, cgULong: begin if ((inPointer & gLong.preference) <> 0) and (disp < 254) then begin @@ -5007,6 +5135,13 @@ procedure GenTree {op: icptr}; GenImplied(m_pla); end; {if} {else do nothing} + + cgQuad, cgUQuad: begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; cgReal, cgDouble, cgComp, cgExtended: begin GenImplied(m_tsc); From 2222e4a0b4100b789d8d0947face6ac355c47bf3 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 29 Jan 2021 23:22:28 -0600 Subject: [PATCH 03/68] Restore old order of baseTypeEnum values. The ordinal values of these are hard-coded in code for handling pc_cnv/pc_cnn, so let's avoid changing them. --- CCommon.pas | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CCommon.pas b/CCommon.pas index 2c27e7f..ef0b84c 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -147,9 +147,9 @@ type { the compiler. Any values whose type is cc must be resolved to one } { of the cg types before the code generator is called. } - baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, + baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong, cgReal,cgDouble,cgComp,cgExtended,cgString, - cgVoid,ccPointer); + cgVoid,cgQuad,cgUQuad,ccPointer); { Basic types (plus the void type) as defined by the C language. } { This differs from baseTypeEnum in that different types with the } From 8b12b7b7342578666e91a2d08e35b012f483a39e Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 29 Jan 2021 23:25:21 -0600 Subject: [PATCH 04/68] Handle (unsigned) long long in the front-end code for binary conversions. There is not yet code generation support for the conversion opcodes (pc_cnv/pc_cnn). --- Expression.pas | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/Expression.pas b/Expression.pas index e0814e4..fa4a114 100644 --- a/Expression.pas +++ b/Expression.pas @@ -337,17 +337,41 @@ if (lType^.kind = scalarType) and (rType^.kind = scalarType) then begin rt := Unary(rType^.baseType); if lt <> rt then begin if lt = cgExtended then begin - if rt in [cgWord,cgUWord,cgLong,cgULong] then + if rt in [cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then Gen2(pc_cnv, ord(rt), ord(cgExtended)); UsualBinaryConversions := cgExtended; expressionType := extendedPtr; end {if} else if rt = cgExtended then begin - if lt in [cgWord,cgUWord,cgLong,cgULong] then + if lt in [cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then Gen2(pc_cnn, ord(lt), ord(cgExtended)); UsualBinaryConversions := cgExtended; expressionType := extendedPtr; end {else if} + else if lt = cgUQuad then begin + if rt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnv, ord(rt), ord(cgUQuad)); + UsualBinaryConversions := cgUQuad; + expressionType := uLongLongPtr; + end {else if} + else if rt = cgUQuad then begin + if lt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnn, ord(lt), ord(cgUQuad)); + UsualBinaryConversions := cgUQuad; + expressionType := uLongLongPtr; + end {else if} + else if lt = cgQuad then begin + if rt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnv, ord(rt), ord(cgQuad)); + UsualBinaryConversions := cgQuad; + expressionType := longLongPtr; + end {else if} + else if rt = cgQuad then begin + if lt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnn, ord(lt), ord(cgQuad)); + UsualBinaryConversions := cgQuad; + expressionType := longLongPtr; + end {else if} else if lt = cgULong then begin if rt in [cgWord,cgUWord] then Gen2(pc_cnv, ord(rt), ord(cgULong)); From abb0fa0fc1075806eb0d45fedffea6ab179d6079 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 30 Jan 2021 00:25:15 -0600 Subject: [PATCH 05/68] Implement bitwise and/or/xor for 64-bit types. This introduces three new intermediate codes for these operations. --- CGI.Comments | 6 ++++++ CGI.Debug | 5 ++++- CGI.pas | 3 ++- DAG.pas | 2 +- Expression.pas | 12 ++++++++++++ Gen.pas | 39 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 64 insertions(+), 3 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index 7bf4290..eebd430 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -117,9 +117,11 @@ { } { pc_bnd - bitwise and } { pc_bal - long bitwise and } +{ pc_baq - long long bitwise and } { } { Gen0(pc_bnd) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_bal) cgLong,cgULong } +{ Gen0(pc_baq) cgQuad,cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and anded. The result is placed back on the stack. } @@ -150,9 +152,11 @@ { } { pc_bor - bitwise or } { pc_blr - long bitwise or } +{ pc_bqr - long long bitwise or } { } { Gen0(pc_bor) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_blr) cgLong,cgULong } +{ Gen0(pc_bqr) cgQuad,cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and ored. The result is placed back on the stack. } @@ -160,9 +164,11 @@ { } { pc_bxr - exclusive or } { pc_blx - long exclusive or } +{ pc_bqx - long long exclusive or } { } { Gen0(pc_bxr) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_blx) cgLong,cgULong } +{ Gen0(pc_bqx) cgQuad,cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and exclusive ored. The result is placed back on } diff --git a/CGI.Debug b/CGI.Debug index dffc2ce..cc3d0ec 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -116,6 +116,9 @@ opt[dc_prm] := 'PRM'; opt[pc_nat] := 'nat'; opt[pc_bno] := 'bno'; opt[pc_nop] := 'nop'; +opt[pc_bqr] := 'bqr'; +opt[pc_bqx] := 'bqx'; +opt[pc_baq] := 'baq'; end; {InitWriteCode} @@ -261,7 +264,7 @@ with code^ do pc_uml,pc_adr,pc_dvr,pc_mpr,pc_adi,pc_sbi,pc_mpi,pc_dvi, pc_umi,pc_shl,pc_nop,pc_and,pc_lnd,pc_bnd,pc_lor,pc_ior,pc_bxr, pc_bnt,pc_blx,pc_bnl,pc_ngi,pc_ngl,pc_ngr,pc_ixa,pc_mdl, - pc_udi,pc_udl: ; + pc_udi,pc_udl,pc_bqr,pc_bqx,pc_baq: ; dc_prm: write(' ', q:1, ':', r:1, ':', s:1); diff --git a/CGI.pas b/CGI.pas index 6dac8c6..7d1fc30 100644 --- a/CGI.pas +++ b/CGI.pas @@ -228,7 +228,8 @@ type 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); + dc_prm,pc_nat,pc_bno,pc_nop,pc_psh,pc_ili,pc_iil,pc_ild,pc_idl, + pc_bqr,pc_bqx,pc_baq); {intermediate code} {-----------------} diff --git a/DAG.pas b/DAG.pas index 7601ca3..32b139c 100644 --- a/DAG.pas +++ b/DAG.pas @@ -4938,7 +4938,7 @@ case code^.opcode of pc_les, pc_neq, pc_ior, pc_lor, pc_ixa, pc_mod, pc_uim, pc_mdl, pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, - pc_tri, pc_sbf, pc_sto, pc_cui: + pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq: begin code^.right := Pop; code^.left := Pop; diff --git a/Expression.pas b/Expression.pas index fa4a114..e1f3ad7 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3147,6 +3147,8 @@ case tree^.token.kind of Gen0(pc_bnd) else if et in [cgLong,cgULong] then Gen0(pc_bal) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_baq) else Error(66); @@ -3155,6 +3157,8 @@ case tree^.token.kind of Gen0(pc_bxr) else if et in [cgLong,cgULong] then Gen0(pc_blx) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_bqx) else Error(66); @@ -3163,6 +3167,8 @@ case tree^.token.kind of Gen0(pc_bor) else if et in [cgLong,cgULong] then Gen0(pc_blr) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_bqr) else Error(66); @@ -3278,6 +3284,8 @@ case tree^.token.kind of Gen0(pc_bxr); cgLong,cgULong: Gen0(pc_blx); + cgQuad,cgUQuad: + Gen0(pc_bqx); otherwise: error(66); end; {case} @@ -3294,6 +3302,8 @@ case tree^.token.kind of Gen0(pc_bor); cgLong,cgULong: Gen0(pc_blr); + cgQuad,cgUQuad: + Gen0(pc_bqr); otherwise: error(66); end; {case} @@ -3310,6 +3320,8 @@ case tree^.token.kind of Gen0(pc_bnd); cgLong,cgULong: Gen0(pc_bal); + cgQuad,cgUQuad: + Gen0(pc_baq); otherwise: error(66); end; {case} diff --git a/Gen.pas b/Gen.pas index f698f26..9545647 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4095,6 +4095,44 @@ procedure GenTree {op: icptr}; end; {GenBinLong} + procedure GenBinQuad (op: icptr); + + { generate one of: pc_bqr, pc_bqx, pc_baq } + + procedure GenOp (ops: integer); + + { generate a 64-bit binary bitwise operation } + { } + { parameters: } + { ops - stack version of operation } + + begin {GenOp} + GenImplied(m_pla); + GenNative(ops, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(ops, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(ops, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(ops, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + end; {GenOp} + + begin {GenBinQuad} + GenTree(op^.left); + GenTree(op^.right); + case op^.opcode of + pc_bqr: GenOp(m_ora_s); + pc_bqx: GenOp(m_eor_s); + pc_baq: GenOp(m_and_s); + otherwise: Error(cge1); + end; {case} + end; {GenBinQuad} + + procedure GenBno (op: icptr); { Generate code for a pc_bno } @@ -5678,6 +5716,7 @@ case op^.opcode of pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, pc_uml,pc_vsr: GenBinLong(op); + pc_bqr,pc_bqx,pc_baq: GenBinQuad(op); pc_bnl,pc_ngl: GenUnaryLong(op); pc_bno: GenBno(op); pc_bnt,pc_ngi,pc_not: GenBntNgiNot(op); From 2e44c36c595e760c0f92ac67931477dfc05a0762 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 30 Jan 2021 13:49:06 -0600 Subject: [PATCH 06/68] Implement unary negation and bitwise complement for 64-bit types. --- CGI.Comments | 4 ++++ CGI.Debug | 2 ++ CGI.pas | 2 +- DAG.pas | 2 +- Expression.pas | 4 ++++ Gen.pas | 44 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 56 insertions(+), 2 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index eebd430..37b9bef 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -142,9 +142,11 @@ { } { pc_bnt - bitwise negation } { pc_bnl - long bitwise negation } +{ pc_bnq - long long bitwise negation } { } { Gen0(pc_bnt) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_bnl) cgLong,cgULong } +{ Gen0(pc_bnq) cgQuad,cgUQuad } { } { The value on the top of the evaluation stack is removed, } { exclusive ored with $FFFF, and replaced. (One's compliment.)} @@ -490,10 +492,12 @@ { } { pc_ngi - integer negation } { pc_ngl - long negation } +{ pc_ngq - long long negation } { pc_ngr - real negation } { } { Gen0(pc_ngi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_ngl) cgLong,cgULong } +{ Gen0(pc_ngq) cgQuad,cgUQuad } { Gen0(pc_ngr) cgReal,cgDouble,cgComp,cgExtended } { } { The value on the top of the evaluation stack is removed, } diff --git a/CGI.Debug b/CGI.Debug index cc3d0ec..48a762c 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -119,6 +119,8 @@ opt[pc_nop] := 'nop'; opt[pc_bqr] := 'bqr'; opt[pc_bqx] := 'bqx'; opt[pc_baq] := 'baq'; +opt[pc_bnq] := 'bnq'; +opt[pc_ngq] := 'ngq'; end; {InitWriteCode} diff --git a/CGI.pas b/CGI.pas index 7d1fc30..ac6f87d 100644 --- a/CGI.pas +++ b/CGI.pas @@ -229,7 +229,7 @@ type 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_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq); {intermediate code} {-----------------} diff --git a/DAG.pas b/DAG.pas index 32b139c..75a447a 100644 --- a/DAG.pas +++ b/DAG.pas @@ -4926,7 +4926,7 @@ case code^.opcode of pc_bnt, pc_bnl, pc_cnv, pc_dec, pc_inc, pc_ind, pc_lbf, pc_lbu, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_stk, pc_cop, pc_cpo, pc_tl1, pc_sro, pc_str, pc_fjp, pc_tjp, pc_xjp, pc_cup, pc_pop, pc_iil, - pc_ili, pc_idl, pc_ild: + pc_ili, pc_idl, pc_ild, pc_bnq, pc_ngq: begin code^.left := Pop; Push(code); diff --git a/Expression.pas b/Expression.pas index e1f3ad7..053f79e 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3597,6 +3597,8 @@ case tree^.token.kind of Gen0(pc_ngi); cgLong,cgULong: Gen0(pc_ngl); + cgQuad,cgUQuad: + Gen0(pc_ngq); cgExtended: Gen0(pc_ngr); otherwise: @@ -3613,6 +3615,8 @@ case tree^.token.kind of Gen0(pc_bnt); cgLong,cgULong: Gen0(pc_bnl); + cgQuad,cgUQuad: + Gen0(pc_bnq); otherwise: error(66); end; {case} diff --git a/Gen.pas b/Gen.pas index 9545647..8cfef46 100644 --- a/Gen.pas +++ b/Gen.pas @@ -3932,6 +3932,49 @@ gLong.where := onStack; {the result is on the stack} end; {GenUnaryLong} +procedure GenUnaryQuad (op: icptr); + +{ generate a pc_bnq or pc_ngq } + +begin {GenUnaryQuad} +GenTree(op^.left); +case op^.opcode of {do the operation} + + pc_bnq: begin + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 1, nil, 0); + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 3, nil, 0); + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 5, nil, 0); + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + end; {case pc_bnq} + + pc_ngq: begin + GenImplied(m_sec); + GenNative(m_ldy_imm, immediate, 0, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 1, nil, 0); + GenNative(m_sta_s, direct, 1, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 3, nil, 0); + GenNative(m_sta_s, direct, 3, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 5, nil, 0); + GenNative(m_sta_s, direct, 5, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + end; {case pc_ngq} + end; {case} +end; {GenUnaryQuad} + + procedure GenTree {op: icptr}; { generate code for op and its children } @@ -5718,6 +5761,7 @@ case op^.opcode of pc_uml,pc_vsr: GenBinLong(op); pc_bqr,pc_bqx,pc_baq: GenBinQuad(op); pc_bnl,pc_ngl: GenUnaryLong(op); + pc_bnq,pc_ngq: GenUnaryQuad(op); pc_bno: GenBno(op); pc_bnt,pc_ngi,pc_not: GenBntNgiNot(op); pc_cnv: GenCnv(op); From 2426794194f92f556d9b9668d95ab03855cc5a90 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 30 Jan 2021 21:11:06 -0600 Subject: [PATCH 07/68] Add support for new pcodes in optimizer. --- DAG.pas | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/DAG.pas b/DAG.pas index 75a447a..d59bcf0 100644 --- a/DAG.pas +++ b/DAG.pas @@ -110,7 +110,7 @@ function CodesMatch (op1, op2: icptr; exact: boolean): boolean; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor, pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi, - pc_umi, pc_mpl, pc_uml, pc_mpr: begin + pc_umi, pc_mpl, pc_uml, pc_mpr, pc_bqr, pc_bqx, pc_baq: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; @@ -2266,6 +2266,9 @@ case op^.opcode of pc_udl, pc_ulm, pc_uml, pc_vsr: TypeOf := cgULong; + pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq: + TypeOf := cgQuad; + pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: TypeOf := cgExtended; @@ -4058,7 +4061,8 @@ var pc_ixa,pc_lad,pc_lao,pc_lca,pc_lda,pc_ldc,pc_mod,pc_uim, pc_mdl,pc_ulm,pc_mpi,pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi, pc_ngl,pc_ngr,pc_not,pc_pop,pc_sbi,pc_sbl,pc_sbr, - pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri] + pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri, + pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq] then begin op^.parents := icount; icount := icount+1; From 807a143e511c6b93780c30996fd281c208dbb75d Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 30 Jan 2021 23:31:18 -0600 Subject: [PATCH 08/68] Implement 64-bit addition and subtraction. --- CGI.Comments | 4 ++++ CGI.pas | 2 +- DAG.pas | 9 +++++---- Expression.pas | 8 ++++++++ Gen.pas | 44 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 62 insertions(+), 5 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index 37b9bef..8640597 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -90,10 +90,12 @@ { } { pc_adi - integer addition } { pc_adl - long addition } +{ pc_adq - long long addition } { pc_adr - real addition } { } { Gen0(pc_adi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_adl) cgLong,cgULong } +{ Gen0(pc_adq) cgQuad,cgUQuad } { Gen0(pc_adr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } @@ -547,10 +549,12 @@ { } { pc_sbi - integer subtraction } { pc_sbl - long subtraction } +{ pc_sbq - long long subtraction } { pc_sbr - real subtraction } { } { Gen0(pc_sbi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_sbl) cgLong,cgULong } +{ Gen0(pc_sbq) cgQuad,cgUQuad } { Gen0(pc_sbr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } diff --git a/CGI.pas b/CGI.pas index ac6f87d..fa81c44 100644 --- a/CGI.pas +++ b/CGI.pas @@ -229,7 +229,7 @@ type 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_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq); {intermediate code} {-----------------} diff --git a/DAG.pas b/DAG.pas index d59bcf0..fe777da 100644 --- a/DAG.pas +++ b/DAG.pas @@ -110,7 +110,7 @@ function CodesMatch (op1, op2: icptr; exact: boolean): boolean; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor, pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi, - pc_umi, pc_mpl, pc_uml, pc_mpr, pc_bqr, pc_bqx, pc_baq: begin + pc_umi, pc_mpl, pc_uml, pc_mpr, pc_bqr, pc_bqx, pc_baq, pc_adq: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; @@ -2266,7 +2266,7 @@ case op^.opcode of pc_udl, pc_ulm, pc_uml, pc_vsr: TypeOf := cgULong; - pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq: + pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq: TypeOf := cgQuad; pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: @@ -4062,7 +4062,7 @@ var pc_mdl,pc_ulm,pc_mpi,pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi, pc_ngl,pc_ngr,pc_not,pc_pop,pc_sbi,pc_sbl,pc_sbr, pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri, - pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq] + pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq] then begin op^.parents := icount; icount := icount+1; @@ -4942,7 +4942,8 @@ case code^.opcode of pc_les, pc_neq, pc_ior, pc_lor, pc_ixa, pc_mod, pc_uim, pc_mdl, pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, - pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq: + pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq, pc_adq, + pc_sbq: begin code^.right := Pop; code^.left := Pop; diff --git a/Expression.pas b/Expression.pas index 053f79e..e07067d 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3063,6 +3063,8 @@ case tree^.token.kind of Gen0(pc_adi) else if et in [cgLong,cgULong] then Gen0(pc_adl) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_adq) else if et = cgExtended then Gen0(pc_adr) else @@ -3077,6 +3079,8 @@ case tree^.token.kind of Gen0(pc_sbi) else if et in [cgLong,cgULong] then Gen0(pc_sbl) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_sbq) else if et = cgExtended then Gen0(pc_sbr) else @@ -3422,6 +3426,8 @@ case tree^.token.kind of Gen0(pc_adi); cgLong,cgULong: Gen0(pc_adl); + cgQuad,cgUQuad: + Gen0(pc_adq); cgExtended: Gen0(pc_adr); otherwise: @@ -3478,6 +3484,8 @@ case tree^.token.kind of Gen0(pc_sbi); cgLong,cgULong: Gen0(pc_sbl); + cgQuad,cgUQuad: + Gen0(pc_sbq); cgExtended: Gen0(pc_sbr); otherwise: diff --git a/Gen.pas b/Gen.pas index 8cfef46..eee616e 100644 --- a/Gen.pas +++ b/Gen.pas @@ -679,6 +679,49 @@ else begin end; {GenAdlSbl} +procedure GenAdqSbq (op: icptr); + +{ generate code for pc_adq, pc_sbq } +{ } +{ parameters: } +{ op - pc_adq or pc_sbq operation } + +begin {GenAdqSbq} +GenTree(op^.right); +GenTree(op^.left); +if op^.opcode = pc_adq then begin + GenImplied(m_clc); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + end {else} +else {if op^.opcode = pc_sbq then} begin + GenImplied(m_sec); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + end; {else} +end; {GenAdqSbq} + + procedure GenCmp (op: icptr; rOpcode: pcodes; lb: integer); { generate code for pc_les, pc_leq, pc_grt or pc_geq } @@ -5755,6 +5798,7 @@ case op^.opcode of pc_add: GenNative(d_add, genaddress, op^.q, nil, 0); pc_adi: GenAdi(op); pc_adl,pc_sbl: GenAdlSbl(op, nil); + pc_adq,pc_sbq: GenAdqSbq(op); pc_adr,pc_dvr,pc_mpr,pc_sbr: GenRealBinOp(op); pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, From e8497c7b8fc24f65a8ca3b1ace3c99097acf471b Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 31 Jan 2021 08:37:21 -0600 Subject: [PATCH 09/68] Begin implementing conversions to and from 64-bit types. Some conversions are implemented, but others are not yet. --- Gen.pas | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 110 insertions(+) diff --git a/Gen.pas b/Gen.pas index eee616e..4b5bcd9 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1175,33 +1175,45 @@ const {note: these constants list all legal } cComp = $08; cExtended = $09; cVoid = $0B; + cQuad = $0C; + cUQuad = $0D; byteToWord = $02; byteToUword = $03; byteToLong = $04; byteToUlong = $05; + byteToQuad = $0C; + byteToUQuad = $0D; byteToReal = $06; byteToDouble = $07; ubyteToLong = $14; ubyteToUlong = $15; + ubyteToQuad = $1C; + ubyteToUQuad = $1D; ubyteToReal = $16; ubyteToDouble = $17; wordToByte = $20; wordToUByte = $21; wordToLong = $24; wordToUlong = $25; + wordToQuad = $2C; + wordToUQuad = $2D; wordToReal = $26; wordToDouble = $27; uwordToByte = $30; uwordToUByte = $31; uwordToLong = $34; uwordToUlong = $35; + uwordToQuad = $3C; + uwordToUQuad = $3D; uwordToReal = $36; uwordToDouble = $37; longTobyte = $40; longToUbyte = $41; longToWord = $42; longToUword = $43; + longToQuad = $4C; + longToUQuad = $4D; longToReal = $46; longToDouble = $47; longToVoid = $4B; @@ -1209,6 +1221,8 @@ const {note: these constants list all legal } ulongToUbyte = $51; ulongToWord = $52; ulongToUword = $53; + ulongToQuad = $5C; + ulongToUQuad = $5D; ulongToReal = $56; ulongToDouble = $57; ulongToVoid = $5B; @@ -1218,6 +1232,8 @@ const {note: these constants list all legal } realToUword = $63; realToLong = $64; realToUlong = $65; + realToQuad = $6C; + realToUQuad = $6D; realToVoid = $6B; doubleTobyte = $70; doubleToUbyte = $71; @@ -1225,6 +1241,26 @@ const {note: these constants list all legal } doubleToUword = $73; doubleToLong = $74; doubleToUlong = $75; + doubleToQuad = $7C; + doubleToUQuad = $7D; + quadToByte = $C0; + quadToUByte = $C1; + quadToWord = $C2; + quadToUword = $C3; + quadToLong = $C4; + quadToULong = $C5; + quadToReal = $C6; + quadToDouble = $C7; + quadToVoid = $CB; + uquadToByte = $D0; + uquadToUByte = $D1; + uquadToWord = $D2; + uquadToUword = $D3; + uquadToLong = $D4; + uquadToULong = $D5; + uquadToReal = $D6; + uquadToDouble = $D7; + uquadToVoid = $DB; var fromReal: boolean; {are we converting from a real?} @@ -1369,6 +1405,80 @@ else if op^.q in [longToVoid,ulongToVoid] then begin gLong.where := A_X; end; {if} end {else if} +else if op^.q in [ubyteToQuad,ubyteToUQuad,uwordToQuad,uwordToUQuad] then begin + GenNative(m_ldy_imm, immediate, 0, nil, 0); + GenImplied(m_phy); + GenImplied(m_phy); + GenImplied(m_phy); + GenImplied(m_pha); + end {else if} +else if op^.q in [ulongToQuad,ulongToUQuad] then begin + if gLong.where = A_X then begin + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenImplied(m_phx); + GenImplied(m_pha); + end {if} + else if gLong.where = constant then begin + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end {else if} + else {if gLong.where = onStack then} begin + GenImplied(m_pla); + GenImplied(m_plx); + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenImplied(m_phx); + GenImplied(m_pha); + end; {else} + end {else if} +else if op^.q in [quadToWord,uquadToWord,quadToUWord,uquadToUWord] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + GenImplied(m_tay); + end {else if} +else if op^.q in [quadToUByte,uquadToUByte] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + GenNative(m_and_imm, immediate, $00FF, nil, 0); + end {else if} +else if op^.q in [quadToByte,uquadToByte] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + GenNative(m_and_imm, immediate, $00FF, nil, 0); + lab1 := GenLabel; + GenNative(m_bit_imm, immediate, $0080, nil, 0); + GenNative(m_beq, relative, lab1, nil, 0); + GenNative(m_ora_imm, immediate, $FF00, nil, 0); + GenLab(lab1); + end {else if} +else if op^.q in [quadToLong,uquadToLong,quadToULong,uquadToULong] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + if (lLong.preference & A_X) <> 0 then + gLong.where := A_X + else begin + gLong.where := onStack; + GenImplied(m_phx); + GenImplied(m_pha); + end; {else} + end {else if} +else if op^.q in [quadToVoid,uquadToVoid] then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end {else if} else if (op^.q & $000F) = cVoid then {do nothing} else if lLong.preference & gLong.where = 0 then begin From 091a25b25d90ce4466d4f5a0e15b806fc1417fe8 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 31 Jan 2021 20:26:51 -0600 Subject: [PATCH 10/68] Update the debugging format for long long values. For now, "long long" is represented with the existing code for the SANE comp format, since their representation is the same except for the comp NaN. This allows existing debuggers that support comp to work with it. The code for "unsigned long long" includes the unsigned flag, so it is unambiguous. --- Debugger.md | 4 ++-- Symbol.pas | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Debugger.md b/Debugger.md index bb88635..d9aa97e 100644 --- a/Debugger.md +++ b/Debugger.md @@ -105,14 +105,14 @@ The following table shows the format used to store the variable’s current valu 7 Pascal-style string 8 character 9 boolean - 10 SANE COMP number + 10 SANE COMP number or 8-byte integer 11 pointer 12 structure, union or record 13 derived type 14 object -One-byte integers default to unsigned, while two-byte and four-byte integers default to signed format. `OR`ing the format code with `$40` reverses this default, giving signed one-byte integers or unsigned four-byte integers. (The signed flag is not supported by PRIZM 1.1.3.) +One-byte integers default to unsigned, while two-byte, four-byte, and eight-byte integers default to signed format. `OR`ing the format code with `$40` reverses this default, giving signed one-byte integers or unsigned four-byte integers. (The signed flag is not supported by PRIZM 1.1.3.) A pointer to a scalar type (1-10) is indicated by `OR`ing the value’s format code with `$80`. For example, `$82` would be a pointer to a 4-byte integer. diff --git a/Symbol.pas b/Symbol.pas index 5cc2c1a..5b5c4f4 100644 --- a/Symbol.pas +++ b/Symbol.pas @@ -982,6 +982,8 @@ var cgDouble: val := $04; cgComp: val := $0A; cgExtended: val := $05; + cgQuad: val := $0A; {same as comp} + cgUQuad: val := $4A; otherwise: val := $01; end; {case} CnOut(val | modifiers); {write the format byte} From 1dc0dc7a19e74b4748d2eca1275692db94dabf31 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Mon, 1 Feb 2021 22:43:35 -0600 Subject: [PATCH 11/68] Implement remaining conversions of integer types to and from long long. The floating-point conversions are not done yet (but do now give an error). --- Gen.pas | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 66 insertions(+), 4 deletions(-) diff --git a/Gen.pas b/Gen.pas index 5a64137..01e1e9a 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1310,14 +1310,14 @@ else if op^.q in [byteToLong,byteToUlong] then begin GenImplied(m_phx); GenImplied(m_pha); end; {else} - end {if} + end {else if} else if op^.q in [byteToWord,byteToUword] then begin lab1 := GenLabel; GenNative(m_bit_imm, immediate, $0080, nil, 0); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); - end {if} + end {else if} else if op^.q in [ubyteToLong,ubyteToUlong,uwordToLong,uwordToUlong] then begin if (lLong.preference & A_X) <> 0 then begin @@ -1395,8 +1395,8 @@ else if op^.q in [longToReal,uLongToReal] then begin GenCall(12) else GenCall(13); - end {else} -else if op^.q =realToWord then + end {else if} +else if op^.q = realToWord then GenCall(14) else if op^.q = realToUbyte then begin GenCall(14); @@ -1446,6 +1446,31 @@ else if op^.q in [ubyteToQuad,ubyteToUQuad,uwordToQuad,uwordToUQuad] then begin GenImplied(m_phy); GenImplied(m_pha); end {else if} +else if op^.q in [byteToQuad,byteToUQuad] then begin + lab1 := GenLabel; + GenNative(m_ldx_imm, immediate, 0, nil, 0); + GenNative(m_bit_imm, immediate, $0080, nil, 0); + GenNative(m_beq, relative, lab1, nil, 0); + GenImplied(m_dex); + GenNative(m_ora_imm, immediate, $FF00, nil, 0); + GenLab(lab1); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_pha); + end {else if} +else if op^.q in [wordToQuad,wordToUQuad] then begin + lab1 := GenLabel; + GenNative(m_ldx_imm, immediate, 0, nil, 0); + GenImplied(m_tay); + GenNative(m_bpl, relative, lab1, nil, 0); + GenImplied(m_dex); + GenLab(lab1); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_pha); + end {else if} else if op^.q in [ulongToQuad,ulongToUQuad] then begin if gLong.where = A_X then begin GenNative(m_pea, immediate, 0, nil, 0); @@ -1468,6 +1493,41 @@ else if op^.q in [ulongToQuad,ulongToUQuad] then begin GenImplied(m_pha); end; {else} end {else if} +else if op^.q in [longToQuad,longToUQuad] then begin + if gLong.where = constant then begin + if glong.lval < 0 then begin + GenNative(m_pea, immediate, -1, nil, 0); + GenNative(m_pea, immediate, -1, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end {if} + else begin + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end; {else} + end {if} + else begin + GenNative(m_ldy_imm, immediate, 0, nil, 0); + if gLong.where = onStack then begin + GenImplied(m_pla); + GenImplied(m_plx); + end {if} + else {if gLong.where = A_X then} + GenNative(m_cpx_imm, immediate, 0, nil, 0); + lab1 := GenLabel; + GenNative(m_bpl, relative, lab1, nil, 0); + GenImplied(m_dey); + GenLab(lab1); + GenImplied(m_phy); + GenImplied(m_phy); + GenImplied(m_phx); + GenImplied(m_pha); + end; {else} + end {else if} +else if op^.q in [realToQuad, realToUQuad] then + Error(cge1) {TODO: implement} else if op^.q in [quadToWord,uquadToWord,quadToUWord,uquadToUWord] then begin GenImplied(m_pla); GenImplied(m_plx); @@ -1513,6 +1573,8 @@ else if op^.q in [quadToVoid,uquadToVoid] then begin GenNative(m_adc_imm, immediate, 8, nil, 0); GenImplied(m_tcs); end {else if} +else if op^.q in [quadToReal, uquadToReal] then + Error(cge1) {TODO: implement} else if (op^.q & $000F) = cVoid then {do nothing} else if lLong.preference & gLong.where = 0 then begin From 6a2ea6ccc4334f28751319f9f15a22344acfa9c5 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Tue, 2 Feb 2021 18:18:50 -0600 Subject: [PATCH 12/68] Implement equality/inequality comparisons for 64-bit types. --- Gen.pas | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/Gen.pas b/Gen.pas index 01e1e9a..af7898d 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1606,7 +1606,7 @@ procedure GenEquNeq (op: icptr; opcode: pcodes; lb: integer); var nd: icptr; {work node} num: integer; {constant to compare to} - lab1,lab2: integer; {label numbers} + lab1,lab2,lab3: integer; {label numbers} bne: integer; {instruction for a pc_equ bne branch} beq: integer; {instruction for a pc_equ beq branch} lLong: longType; {local long value information} @@ -1899,7 +1899,57 @@ else end {if} else if op^.opcode = pc_neq then GenNative(m_eor_imm, immediate, 1, nil, 0); - end; {case optype of cgReal..cgExtended,cgSet,cgString} + end; {case optype of cgReal..cgExtended} + + cgQuad,cgUQuad: begin + GenTree(op^.left); + GenTree(op^.right); + + lab1 := GenLabel; + lab2 := GenLabel; + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenNative(m_eor_s, direct, 3, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_txa); + GenNative(m_eor_s, direct, 5, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_tya); + GenNative(m_eor_s, direct, 7, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_pla); + GenNative(m_eor_s, direct, 7, nil, 0); + GenNative(m_bra, relative, lab2, nil, 0); + GenLab(lab1); + GenImplied(m_plx); + GenLab(lab2); + GenImplied(m_tax); + + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + + GenImplied(m_txa); + if opcode in [pc_fjp,pc_tjp] then begin + lab3 := GenLabel; + if opcode = pc_fjp then + GenNative(beq, relative, lab3, nil, 0) + else + GenNative(bne, relative, lab3, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab3); + end {if} + else begin + lab3 := GenLabel; + GenNative(m_beq, relative, lab3, nil, 0); + GenNative(m_lda_imm, immediate, 1, nil, 0); + GenLab(lab3); + if op^.opcode = pc_equ then + GenNative(m_eor_imm, immediate, 1, nil, 0); + end; {else} + end; {case optype of cgQuad,cgUQuad} otherwise: Error(cge1); From 793f0a57cc5dabeb0e95abfac47bc6bd9d1ccbdb Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Wed, 3 Feb 2021 23:11:23 -0600 Subject: [PATCH 13/68] Initial support for constants with long long types. Currently, the actual values they can have are still constrained to the 32-bit range. Also, there are some bits of functionality (e.g. for initializers) that are not implemented yet. --- CCommon.pas | 9 +++++--- CGI.pas | 29 +++++++++++++++++++++++++ DAG.pas | 4 ++-- Expression.pas | 36 ++++++++++++++++++++++++++++-- Gen.pas | 7 ++++++ Header.pas | 10 ++++++++- Parser.pas | 23 +++++++++++++++----- Scanner.pas | 59 ++++++++++++++++++++++++++++++++++++++------------ Table.asm | 10 +++++++-- 9 files changed, 157 insertions(+), 30 deletions(-) diff --git a/CCommon.pas b/CCommon.pas index ef0b84c..8b9c340 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -114,7 +114,7 @@ type {Misc.} {-----} long = record lsw,msw: integer; end; {for extracting words from longints} - longlong = record low32,high32: longint; end; {64-bit integer representation} + longlong = record lo,hi: longint; end; {64-bit integer representation} cString = packed array [1..256] of char; {null terminated string} cStringPtr = ^cString; @@ -167,7 +167,8 @@ type tokenEnum = ( {enumeration of the tokens} ident, {identifiers} {constants} - intconst,uintconst,longconst,ulongconst,doubleconst, + intconst,uintconst,longconst,ulongconst,longlongconst, + ulonglongconst,doubleconst, stringconst, {reserved words} _Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy, @@ -208,7 +209,7 @@ type tokenSet = set of tokenEnum; tokenClass = (reservedWord,reservedSymbol,identifier,intConstant,longConstant, - doubleConstant,stringConstant,macroParameter); + longlongConstant,doubleConstant,stringConstant,macroParameter); identPtr = ^identRecord; {^ to a symbol table entry} tokenType = record {a token} kind: tokenEnum; {kind of token} @@ -220,6 +221,7 @@ type symbolPtr: identPtr); intConstant : (ival: integer); longConstant : (lval: longint); + longlongConstant: (qval: longlong); doubleConstant: (rval: double); stringConstant: (sval: longstringPtr; ispstring: boolean); @@ -487,6 +489,7 @@ var {------------------} doDispose: boolean; {dispose of the expression tree as we go?} realExpressionValue: double; {value of the last real constant expression} + longlongExpressionValue: longlong; {value of the last long long constant expression} expressionValue: longint; {value of the last constant expression} expressionType: typePtr; {the type of the expression} initializerTree: tokenPtr; {for non-constant initializers} diff --git a/CGI.pas b/CGI.pas index fa81c44..b87c48b 100644 --- a/CGI.pas +++ b/CGI.pas @@ -575,6 +575,14 @@ procedure GenLdcLong (lval: longint); { lval - value to load } +procedure GenLdcQuad (qval: longlong); + +{ load a long long constant } +{ } +{ parameters: } +{ qval - value to load } + + procedure GenLdcReal (rval: double); { load a real constant } @@ -1238,6 +1246,27 @@ if codeGeneration then begin 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.lo := qval.lo; + lcode^.qval.hi := qval.hi; + Gen0(pc_ldc); + end; {if} +end; {GenLdcQuad} + + procedure GenTool {fop: pcodes; fp1, fp2: integer; dispatcher: longint}; { generate a tool call } diff --git a/DAG.pas b/DAG.pas index fe777da..8af07b9 100644 --- a/DAG.pas +++ b/DAG.pas @@ -167,8 +167,8 @@ else if (op1 <> nil) and (op2 <> nil) then if op1^.lval = op2^.lval then CodesMatch := true; cgQuad, cgUQuad: - if op1^.qval.low32 = op2^.qval.low32 then - if op1^.qval.high32 = op2^.qval.high32 then + if op1^.qval.lo = op2^.qval.lo then + if op1^.qval.hi = op2^.qval.hi then CodesMatch := true; cgReal, cgDouble, cgComp, cgExtended: if op1^.rval = op2^.rval then diff --git a/Expression.pas b/Expression.pas index e07067d..65aa3ec 100644 --- a/Expression.pas +++ b/Expression.pas @@ -2810,6 +2810,8 @@ var if opType^.baseType in [cgByte,cgWord,cgUByte,cgUWord,cgLong,cgULong] then if ((divisor.class = intConstant) and (divisor.ival = 0)) or ((divisor.class = longConstant) and (divisor.lval = 0)) + or ((divisor.class = longlongConstant) + and (divisor.qval.lo = 0) and (divisor.qval.hi = 0)) or ((divisor.class = doubleConstant) and (divisor.rval = 0.0)) then Error(129); end; {CheckDivByZero} @@ -2831,6 +2833,12 @@ var shiftCount := shiftCountTok.ival else if shiftCountTok.class = longConstant then shiftCount := shiftCountTok.lval + else if shiftCountTok.class = longlongConstant then begin + if shiftCountTok.qval.hi = 0 then + shiftCount := shiftCountTok.qval.lo + else + shiftCount := -1; + end {else if} else shiftCount := 0; @@ -2911,6 +2919,18 @@ case tree^.token.kind of lastconst := tree^.token.lval; end; {case longConst} + longlongConst,ulonglongConst: begin + GenLdcQuad(tree^.token.qval); + if tree^.token.kind = longlongConst then + expressionType := longlongPtr + else + expressionType := ulonglongPtr; + if (tree^.token.qval.hi = 0) and (tree^.token.qval.lo >= 0) then begin + lastwasconst := true; + lastconst := tree^.token.qval.lo; + end; {if} + end; {case longlongConst} + doubleConst: begin GenLdcReal(tree^.token.rval); expressionType := doublePtr; @@ -3920,6 +3940,18 @@ else begin {record the expression for an initialize expressionType := ulongPtr; isConstant := true; end {else if} + else if tree^.token.kind = longlongconst then begin + longlongExpressionValue.lo := tree^.token.qval.lo; + longlongExpressionValue.hi := tree^.token.qval.hi; + expressionType := longLongPtr; + isConstant := true; + end {else if} + else if tree^.token.kind = ulonglongconst then begin + longlongExpressionValue.lo := tree^.token.qval.lo; + longlongExpressionValue.hi := tree^.token.qval.hi; + expressionType := ulongLongPtr; + isConstant := true; + end {else if} else if tree^.token.kind = doubleconst then begin realExpressionValue := tree^.token.rval; expressionType := extendedPtr; @@ -3955,8 +3987,8 @@ procedure InitExpression; { initialize the expression handler } begin {InitExpression} -startTerm := [ident,intconst,uintconst,longconst,ulongconst,doubleconst, - stringconst,_Genericsy]; +startTerm := [ident,intconst,uintconst,longconst,ulongconst,longlongconst, + ulonglongconst,doubleconst,stringconst,_Genericsy]; startExpression:= startTerm + [lparench,asteriskch,andch,plusch,minusch,excch,tildech,sizeofsy, plusplusop,minusminusop,typedef,_Alignofsy]; diff --git a/Gen.pas b/Gen.pas index af7898d..20a8389 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4986,6 +4986,13 @@ procedure GenTree {op: icptr}; GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0); end; + cgQuad,cgUQuad: begin + GenNative(m_pea, immediate, long(op^.qval.hi).msw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.hi).lsw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.lo).msw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.lo).lsw, nil, 0); + end; + otherwise: Error(cge1); end; {case} diff --git a/Header.pas b/Header.pas index bcdd8f4..731c3ce 100644 --- a/Header.pas +++ b/Header.pas @@ -18,7 +18,7 @@ uses CCommon, MM, Scanner, Symbol, CGI; {$segment 'SCANNER'} const - symFileVersion = 9; {version number of .sym file format} + symFileVersion = 10; {version number of .sym file format} var inhibitHeader: boolean; {should .sym includes be blocked?} @@ -711,6 +711,10 @@ procedure EndInclude {chPtr: ptr}; identifier: WriteString(token.name); intConstant: WriteWord(token.ival); longConstant: WriteLong(token.lval); + longlongConstant: begin + WriteLong(token.qval.lo); + WriteLong(token.qval.hi); + end; doubleConstant: WriteDouble(token.rval); stringConstant: begin WriteLongString(token.sval); @@ -1331,6 +1335,10 @@ var identifier: token.name := ReadString; intConstant: token.ival := ReadWord; longConstant: token.lval := ReadLong; + longlongConstant: begin + token.qval.lo := ReadLong; + token.qval.hi := ReadLong; + end; doubleConstant: token.rval := ReadDouble; stringConstant: begin token.sval := ReadLongString; diff --git a/Parser.pas b/Parser.pas index 3e4ccca..2835bda 100644 --- a/Parser.pas +++ b/Parser.pas @@ -1846,6 +1846,8 @@ var size := rtree^.token.ival else if rtree^.token.kind in [longconst,ulongconst] then size := rtree^.token.lval + else if rtree^.token.kind in [longlongconst,ulonglongconst] then + size := rtree^.token.qval.lo else begin Error(18); errorFound := true; @@ -2056,11 +2058,13 @@ var operator := tree^.token.kind; while operator in [plusch,minusch] do begin with tree^.right^.token do - if kind in [intConst,longConst] then begin + if kind in [intConst,longConst,longlongConst] then begin if kind = intConst then offSet2 := ival - else - offset2 := lval; + else if kind = longConst then + offset2 := lval + else {if kind = longlongConst then} + offset2 := qval.lo; if operator = plusch then offset := offset + offset2 else @@ -4179,12 +4183,19 @@ var {do assignment conversions} while tree^.token.kind = castoper do tree := tree^.left; - isConstant := tree^.token.class in [intConstant,longConstant]; + isConstant := + tree^.token.class in [intConstant,longConstant,longlongConstant]; if isConstant then if tree^.token.class = intConstant then val := tree^.token.ival - else - val := tree^.token.lval; + else if tree^.token.class = longConstant then + val := tree^.token.lval + else {if tree^.token.class = longlongConstant then} begin + if (tree^.token.qval.hi = 0) and (tree^.token.qval.lo >= 0) then + val := tree^.token.qval.lo + else + isConstant := false; + end; {else} { if isConstant then if tree^.token.class = intConstant then diff --git a/Scanner.pas b/Scanner.pas index 67b81bf..ddacdce 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -272,6 +272,7 @@ var lintErrors: set of 1..maxLint; {lint error codes} spaceStr: string[2]; {string ' ' (used in stringization)} quoteStr: string[2]; {string '"' (used in stringization)} + numericConstants: set of tokenClass; {token classes for numeric constants} {-- External procedures; see expression evaluator for notes ----} @@ -742,6 +743,9 @@ case token.kind of longConst, ulongConst: write(token.lval:1); + + longlongConst, + ulonglongConst: write('0x...'); {TODO implement} doubleConst: write(token.rval:1); @@ -1043,7 +1047,7 @@ if class1 in [identifier,reservedWord] then begin str2 := tk2.name else if class2 = reservedWord then str2 := @reservedWords[kind2] - else if class2 in [intConstant,longConstant,doubleConstant] then + else if class2 in numericConstants then str2 := tk2.numString else begin Error(63); @@ -1067,8 +1071,8 @@ if class1 in [identifier,reservedWord] then begin goto 1; end {class1 in [identifier,reservedWord]} -else if class1 in [intConstant,longConstant,doubleConstant] then begin - if class2 in [intConstant,longConstant,doubleConstant] then +else if class1 in numericConstants then begin + if class2 in numericConstants then str2 := tk2.numString else if class2 = identifier then str2 := tk2.name @@ -1086,7 +1090,7 @@ else if class1 in [intConstant,longConstant,doubleConstant] then begin tk1 := token; token := lt; goto 1; - end {else if class1 in [intConstant,longConstant,doubleConstant]} + end {else if class1 in numericConstants} else if class1 = stringConstant then begin if class2 = stringConstant then begin @@ -1106,7 +1110,7 @@ else if class1 = stringConstant then begin end {else if} else if kind1 = dotch then begin - if class2 in [intConstant,longConstant,doubleConstant] then begin + if class2 in numericConstants then begin workString := concat(tk1.numString^, tk2.numString^); lt := token; DoNumber(true); @@ -1114,7 +1118,7 @@ else if kind1 = dotch then begin token := lt; goto 1; end; {if} - end {else if class1 in [intConstant,longConstant,doubleConstant]} + end {else if class1 in numericConstants} else if kind1 = poundch then begin if kind2 = poundch then begin @@ -1846,7 +1850,7 @@ else begin new(tempString); tempString^[0] := chr(0); while - (token.class in [reservedWord,intconstant,longconstant,doubleconstant]) + (token.class in ([reservedWord] + numericConstants)) or (token.kind in [dotch,ident]) do begin if token.kind = ident then tempString^ := concat(tempString^, token.name^) @@ -1854,7 +1858,7 @@ else begin tempString^ := concat(tempString^, '.') else if token.class = reservedWord then tempString^ := concat(tempString^, reservedWords[token.kind]) - else {if token.class in [intconst,longconst,doubleconst] then} + else {if token.class in numericConstants then} tempString^ := concat(tempString^, token.numstring^); NextToken; end; {while} @@ -2317,6 +2321,10 @@ var longConstant: if tk1^.token.lval <> tk2^.token.lval then goto 3; + longlongConstant: + if (tk1^.token.qval.lo <> tk2^.token.qval.lo) or + (tk1^.token.qval.hi <> tk2^.token.qval.hi) then + goto 3; doubleConstant: if tk1^.token.rval <> tk2^.token.rval then goto 3; @@ -3145,12 +3153,14 @@ var isBin: boolean; {is the value a binary number?} isHex: boolean; {is the value a hex number?} isLong: boolean; {is the value a long number?} + isLongLong: boolean; {is the value a long long number?} isReal: boolean; {is the value a real number?} numIndex: 0..maxLine; {index into workString} sp: stringPtr; {for saving identifier names} stringIndex: 0..maxLine; {length of the number string} unsigned: boolean; {is the number unsigned?} val: integer; {value of a digit} + c1: char; {saved copy of last character} numString: pString; {characters in the number} @@ -3217,6 +3227,7 @@ isBin := false; {assume it's not binary} isHex := false; {assume it's not hex} isReal := false; {assume it's an integer} isLong := false; {assume a short integer} +isLongLong := false; unsigned := false; {assume signed numbers} stringIndex := 0; {no digits so far...} if scanWork then begin {set up the scanner} @@ -3276,11 +3287,17 @@ if c2 in ['e','E'] then begin {handle an exponent} end; {if} 1: while c2 in ['l','u','L','U'] do {check for long or unsigned} - if c2 in ['l','L'] then begin - NextChar; - if isLong then + if c2 in ['l','L'] then begin + if isLong or isLongLong then FlagError(156); - isLong := true; + c1 := c2; + NextChar; + if c2 = c1 then begin + NextChar; + isLongLong := true; + end {if} + else + isLong := true; end {if} else {if c2 in ['u','U'] then} begin NextChar; @@ -3293,6 +3310,8 @@ while c2 in ['l','u','L','U'] do {check for long or unsigned} if c2 in ['f','F'] then begin {allow F designator on reals} if unsigned then FlagError(91); + if isLongLong then + FlagError(156); if not isReal then begin FlagError(100); isReal := true; @@ -3395,7 +3414,17 @@ else begin {hex, octal, & binary} end; {else} if long(token.lval).msw <> 0 then isLong := true; - if isLong then begin + if isLongLong then begin + {TODO support actual long long range} + token.qval.lo := token.lval; + token.qval.hi := 0; + if unsigned then + token.kind := ulonglongConst + else + token.kind := longlongConst; + token.class := longlongConstant; + end {if} + else if isLong then begin if unsigned or (token.lval & $80000000 <> 0) then token.kind := ulongConst else @@ -3718,6 +3747,8 @@ lintErrors := [51,104,105,110,124,125,128,129,130,147,151,152,153,154,155]; spaceStr := ' '; {strings used in stringization} quoteStr := '"'; + {set of classes for numeric constants} +numericConstants := [intConstant,longConstant,longlongConstant,doubleConstant]; new(mp); {__LINE__} mp^.name := @'__LINE__'; @@ -3877,7 +3908,7 @@ repeat intConstant : token.ival := -token.ival; longConstant : token.lval := -token.lval; doubleConstant: token.rval := -token.rval; - otherwise: ; + longlongConstant,otherwise: Error(108); end; {case} end {if} else diff --git a/Table.asm b/Table.asm index e154d9f..fbbf4a9 100644 --- a/Table.asm +++ b/Table.asm @@ -284,7 +284,8 @@ charKinds start character set charSym start single character symbols enum ident,0 identifiers ! constants - enum (intconst,uintconst,longconst,ulongconst,doubleconst) + enum (intconst,uintconst,longconst,ulongconst,longlongconst) + enum (ulonglongconst,doubleconst) enum stringconst ! reserved words enum (_Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy) @@ -356,6 +357,8 @@ icp start in-coming priority for expression dc i1'200' uintconst dc i1'200' longconst dc i1'200' ulongconst + dc i1'200' longlongconst + dc i1'200' ulonglongconst dc i1'200' doubleconst dc i1'200' stringconst dc i1'200' _Alignassy @@ -521,6 +524,8 @@ isp start in stack priority for expression dc i1'0' uintconst dc i1'0' longconst dc i1'0' ulongconst + dc i1'0' longlongconst + dc i1'0' ulonglongconst dc i1'0' doubleconst dc i1'0' stringconst dc i1'0' _Alignassy @@ -893,7 +898,8 @@ wordHash start reserved word hash table enum ident,0 identifiers ! constants - enum (intconst,uintconst,longconst,ulongconst,doubleconst) + enum (intconst,uintconst,longconst,ulongconst,longlongconst) + enum (ulonglongconst,doubleconst) enum stringconst ! reserved words enum (_Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy) From 058c0565c63b0d9ac3a232ba8b9dc6ea2ee9a0f1 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Wed, 3 Feb 2021 23:53:46 -0600 Subject: [PATCH 14/68] Support 64-bit integer constants in hex/octal/binary formats. 64-bit decimal constants are not supported yet. --- Scanner.pas | 48 +++++++++++++++++++++++++++++++++--------------- 1 file changed, 33 insertions(+), 15 deletions(-) diff --git a/Scanner.pas b/Scanner.pas index ddacdce..f0d6078 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -3222,6 +3222,23 @@ var end; {GetDigits} + procedure ShiftAndOrValue (shiftCount, nextDigit: integer); + + { Shift the 64-bit value of token.qval left by shiftCount, } + { then binary-or it with nextDigit. } + + begin {ShiftAndOrValue} + while shiftCount > 0 do begin + token.qval.hi := token.qval.hi << 1; + if (token.qval.lo & $80000000) <> 0 then + token.qval.hi := token.qval.hi | 1; + token.qval.lo := token.qval.lo << 1; + shiftCount := shiftCount - 1; + end; {while} + token.qval.lo := token.qval.lo | nextDigit; + end; {ShiftAndOrValue} + + begin {DoNumber} isBin := false; {assume it's not binary} isHex := false; {assume it's not hex} @@ -3361,11 +3378,12 @@ else if numString[1] <> '0' then begin {convert a decimal integer} end; {else} end {else if} else begin {hex, octal, & binary} - token.lval := 0; + token.qval.lo := 0; + token.qval.hi := 0; if isHex then begin i := 3; while i <= length(numString) do begin - if token.lval & $F0000000 <> 0 then begin + if token.qval.hi & $F0000000 <> 0 then begin i := maxint; if flagOverflows then FlagError(6); @@ -3375,7 +3393,7 @@ else begin {hex, octal, & binary} val := (ord(numString[i])-7) & $000F else val := ord(numString[i]) & $000F; - token.lval := (token.lval << 4) | val; + ShiftAndOrValue(4, val); i := i+1; end; {else} end; {while} @@ -3383,7 +3401,7 @@ else begin {hex, octal, & binary} else if isBin then begin i := 3; while i <= length(numString) do begin - if token.lval & $80000000 <> 0 then begin + if token.qval.hi & $80000000 <> 0 then begin i := maxint; if flagOverflows then FlagError(6); @@ -3391,7 +3409,7 @@ else begin {hex, octal, & binary} else begin if not (numString[i] in ['0','1']) then FlagError(121); - token.lval := (token.lval << 1) | (ord(numString[i]) & $0001); + ShiftAndOrValue(1, ord(numString[i]) & $0001); i := i+1; end; {else} end; {while} @@ -3399,7 +3417,7 @@ else begin {hex, octal, & binary} else begin i := 1; while i <= length(numString) do begin - if token.lval & $E0000000 <> 0 then begin + if token.qval.hi & $E0000000 <> 0 then begin i := maxint; if flagOverflows then FlagError(6); @@ -3407,32 +3425,32 @@ else begin {hex, octal, & binary} else begin if numString[i] in ['8','9'] then FlagError(7); - token.lval := (token.lval << 3) | (ord(numString[i]) & $0007); + ShiftAndOrValue(3, ord(numString[i]) & $0007); i := i+1; end; {else} end; {while} end; {else} - if long(token.lval).msw <> 0 then - isLong := true; + if token.qval.hi <> 0 then + isLongLong := true; + if not isLongLong then + if long(token.qval.lo).msw <> 0 then + isLong := true; if isLongLong then begin - {TODO support actual long long range} - token.qval.lo := token.lval; - token.qval.hi := 0; - if unsigned then + if unsigned or (token.qval.hi & $80000000 <> 0) then token.kind := ulonglongConst else token.kind := longlongConst; token.class := longlongConstant; end {if} else if isLong then begin - if unsigned or (token.lval & $80000000 <> 0) then + if unsigned or (token.qval.lo & $80000000 <> 0) then token.kind := ulongConst else token.kind := longConst; token.class := longConstant; end {if} else begin - if (long(token.lval).lsw & $8000) <> 0 then + if (long(token.qval.lo).lsw & $8000) <> 0 then unsigned := true; if unsigned then token.kind := uintConst From c37fae0f3b315972d1f99ddc9a79c4b0632a5668 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 00:22:56 -0600 Subject: [PATCH 15/68] Add most of the infrastructure to support 64-bit decimal constants. Right now, decimal constants can have long long types based on their suffix, but they are still limited to a maximum value of 2^32-1. This also implements the C99 change where decimal constants without a u suffix always have signed types. Thus, decimal constants of 2^31 and up now have type long long, even if their values could be represented in the type unsigned long. --- Scanner.pas | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/Scanner.pas b/Scanner.pas index f0d6078..96e807a 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -3351,22 +3351,35 @@ else if numString[1] <> '0' then begin {convert a decimal integer} or (not unsigned and (stringIndex = 5) and (numString > '32767')) or (unsigned and (stringIndex = 5) and (numString > '65535')) then isLong := true; - if (stringIndex > 10) or + if (stringIndex > 10) + or (not unsigned and (stringIndex = 10) and (numString > '2147483647')) + or (unsigned and (stringIndex = 10) and (numString > '4294967295')) then + isLongLong := true; + if (stringIndex > 10) or {TODO increase limits} ((stringIndex = 10) and (numString > '4294967295')) then begin numString := '0'; if flagOverflows then FlagError(6); end; {if} - if isLong then begin + if isLongLong then begin + token.class := longlongConstant; + token.qval.hi := 0; + token.qval.lo := Convertsl(numString); {TODO support full 64-bit range} + if unsigned then + token.kind := ulonglongConst + else begin + token.kind := longlongConst; + if token.qval.hi < 0 then + FlagError(6); + end; {else} + end {if} + else if isLong then begin token.class := longConstant; token.lval := Convertsl(numString); if unsigned then token.kind := ulongConst - else begin + else token.kind := longConst; - if token.lval < 0 then - token.kind := ulongConst; - end; {else} end {if} else begin if unsigned then From 168a06b7bf092fc5312add0d5b63b88a66a764a0 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 02:17:10 -0600 Subject: [PATCH 16/68] Add support for emitting 64-bit constants in statically-initialized data. --- CCommon.pas | 2 +- CGI.Comments | 7 ++++--- CGI.Debug | 2 ++ CGI.pas | 34 ++++++++++++++++++++++++++++++++-- Expression.pas | 6 ++---- Native.pas | 12 ++++++++++-- Parser.pas | 29 +++++++++++++++++++++++++---- Symbol.pas | 4 ++++ 8 files changed, 80 insertions(+), 16 deletions(-) diff --git a/CCommon.pas b/CCommon.pas index 8b9c340..b1eaab0 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -311,7 +311,7 @@ type isStructOrUnion: boolean; {is this a struct or union initializer?} case isConstant: boolean of {is this a constant initializer?} false: (iTree: tokenPtr); - true : ( + true : ( {Note: qVal.lo must overlap iVal} case itype: baseTypeEnum of cgByte, cgUByte, diff --git a/CGI.Comments b/CGI.Comments index 8640597..7f18cb1 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -3,13 +3,14 @@ { dc_cns - generate a constant value } { } { GenL1(dc_cns, lval, count); } +{ GenQ1(dc_cns, qval, count); } { GenR1t(dc_cns, rval, count, type); } { Gen2t(dc_cns, ival, count, type); } { GenS(dc_cns, sptr); } { } -{ Creates COUNT occurrences of the constant lval, rval or } -{ ival, based on the type. In Gen2t can accept byte or word } -{ types. In the case of GenS, the operand is a string } +{ Creates COUNT occurrences of the constant lval, qval, rval } +{ or ival, based on the type. In Gen2t can accept byte or } +{ word types. In the case of GenS, the operand is a string } { constant, and no repeat count is allowed. } { } { } diff --git a/CGI.Debug b/CGI.Debug index 48a762c..c4a8e26 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -338,6 +338,8 @@ with code^ do write(r:1); cgLong,cgULong: write(lval:1); + cgQuad,cgUQuad: + write('***'); cgReal,cgDouble,cgComp,cgExtended: write('***'); cgString: begin diff --git a/CGI.pas b/CGI.pas index b87c48b..3bffb45 100644 --- a/CGI.pas +++ b/CGI.pas @@ -557,6 +557,15 @@ procedure GenL1 (fop: pcodes; lval: longint; fp1: integer); { 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: double; fp1: integer; tp: baseTypeEnum); { generate an instruction that uses a real and an int } @@ -1203,6 +1212,28 @@ if codeGeneration then begin 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: double; fp1: integer; tp: baseTypeEnum}; { generate an instruction that uses a real and an int } @@ -1260,8 +1291,7 @@ begin {GenLdcQuad} if codeGeneration then begin lcode := code; lcode^.optype := cgQuad; - lcode^.qval.lo := qval.lo; - lcode^.qval.hi := qval.hi; + lcode^.qval := qval; Gen0(pc_ldc); end; {if} end; {GenLdcQuad} diff --git a/Expression.pas b/Expression.pas index 65aa3ec..83c7149 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3941,14 +3941,12 @@ else begin {record the expression for an initialize isConstant := true; end {else if} else if tree^.token.kind = longlongconst then begin - longlongExpressionValue.lo := tree^.token.qval.lo; - longlongExpressionValue.hi := tree^.token.qval.hi; + longlongExpressionValue := tree^.token.qval; expressionType := longLongPtr; isConstant := true; end {else if} else if tree^.token.kind = ulonglongconst then begin - longlongExpressionValue.lo := tree^.token.qval.lo; - longlongExpressionValue.hi := tree^.token.qval.hi; + longlongExpressionValue := tree^.token.qval; expressionType := ulongLongPtr; isConstant := true; end {else if} diff --git a/Native.pas b/Native.pas index 9927b49..77262eb 100644 --- a/Native.pas +++ b/Native.pas @@ -346,7 +346,7 @@ procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer; label 1; type - rkind = (k1,k2,k3); {cnv record types} + rkind = (k1,k2,k3,k4); {cnv record types} var ch: char; {temp storage for string constants} @@ -355,7 +355,8 @@ var case rkind of k1: (rval: real;); k2: (dval: double;); - k3: (ival1,ival2,ival3,ival4: integer;); + k3: (qval: longlong); + k4: (ival1,ival2,ival3,ival4: integer;); end; count: integer; {number of constants to repeat} i,j,k: integer; {loop variables} @@ -606,6 +607,13 @@ case mode of CnOut2(long(lval).lsw); CnOut2(long(lval).msw); end; + cgQuad,cgUQuad : begin + cnv.qval := icptr(name)^.qval; + CnOut2(cnv.ival1); + CnOut2(cnv.ival2); + CnOut2(cnv.ival3); + CnOut2(cnv.ival4); + end; cgReal : begin cnv.rval := icptr(name)^.rval; CnOut2(cnv.ival1); diff --git a/Parser.pas b/Parser.pas index 2835bda..4c2e0c5 100644 --- a/Parser.pas +++ b/Parser.pas @@ -1946,7 +1946,13 @@ var variable^.storage := global; if isConstant and (variable^.storage in [external,global,private]) then begin if bitsize = 0 then begin - iPtr^.iVal := expressionValue; + if etype^.baseType in [cgQuad,cgUQuad] then begin + iPtr^.qVal := longlongExpressionValue; + end {if} + else begin + iPtr^.qval.hi := 0; + iPtr^.iVal := expressionValue; + end; {else} iPtr^.itype := tp^.baseType; InitializeBitField; end; {if} @@ -1954,13 +1960,20 @@ var scalarType: begin bKind := tp^.baseType; - if (bKind in [cgByte..cgULong]) - and (etype^.baseType in [cgByte..cgULong]) then begin - if bKind in [cgLong,cgULong] then + if (etype^.baseType in [cgByte..cgULong,cgQuad,cgUQuad]) + and (bKind in [cgByte..cgULong,cgQuad,cgUQuad]) then begin + if bKind in [cgLong,cgULong,cgQuad,cgUQuad] then if eType^.baseType = cgUByte then iPtr^.iVal := iPtr^.iVal & $000000FF else if eType^.baseType = cgUWord then iPtr^.iVal := iPtr^.iVal & $0000FFFF; + if bKind in [cgQuad,cgUQuad] then + if etype^.baseType in [cgByte..cgULong] then + if (etype^.baseType in [cgByte,cgWord,cgLong]) + and (iPtr^.iVal < 0) then + iPtr^.qVal.hi := -1 + else + iPtr^.qVal.hi := 0; goto 3; end; {if} if bKind in [cgReal,cgDouble,cgComp,cgExtended] then begin @@ -2017,6 +2030,14 @@ var Error(47); errorFound := true; end {else} + else if etype^.baseType in [cgQuad,cgUQuad] then + if (longlongExpressionValue.hi = 0) and + (longlongExpressionValue.lo = 0) then + iPtr^.iType := cgULong + else begin + Error(47); + errorFound := true; + end {else} else begin Error(48); errorFound := true; diff --git a/Symbol.pas b/Symbol.pas index 5b5c4f4..0c798e8 100644 --- a/Symbol.pas +++ b/Symbol.pas @@ -494,6 +494,8 @@ procedure DoGlobals; end; cgLong,cgULong: GenL1(dc_cns, ip^.ival, ip^.count); + cgQuad,cgUQuad: + GenQ1(dc_cns, ip^.qval, ip^.count); cgReal,cgDouble,cgComp,cgExtended: GenR1t(dc_cns, ip^.rval, ip^.count, ip^.itype); cgString: @@ -583,6 +585,8 @@ procedure DoGlobals; end; cgLong,cgULong: GenL1(dc_cns, ip^.ival, 1); + cgQuad,cgUQuad: + GenQ1(dc_cns, ip^.qval, 1); cgReal,cgDouble,cgComp,cgExtended: GenR1t(dc_cns, ip^.rval, 1, ip^.itype); cgString: From a59a2427fdc1ae01cca3442ab35d3a5433d4cf78 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 12:35:28 -0600 Subject: [PATCH 17/68] Add some support for ++/-- on long long values. Some more complex cases require pc_ind, which is not implemented yet. --- CCommon.pas | 6 ++++++ Expression.pas | 14 +++++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/CCommon.pas b/CCommon.pas index b1eaab0..cad3a88 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -484,6 +484,8 @@ var partialFileGS: gsosOutString; {partial compile list} sourceFileGS: gsosOutString; {debug source file name} tempList: tempPtr; {list of temp work variables} + longlong0: longlong; {the value 0 as a longlong} + longlong1: longlong; {the value 1 as a longlong} {expression results} {------------------} @@ -851,6 +853,10 @@ spinner[0] := '|'; {set up the spinner characters} spinner[1] := '/'; spinner[2] := '-'; spinner[3] := '\'; +longlong0.hi := 0; +longlong0.lo := 0; +longlong1.hi := 0; +longlong1.lo := 1; end; {InitCCommon} diff --git a/Expression.pas b/Expression.pas index 83c7149..e807c8b 100644 --- a/Expression.pas +++ b/Expression.pas @@ -2364,6 +2364,14 @@ var Gen0(pc_sbl); end; + cgQuad,cgUQuad: begin + GenLdcQuad(longlong1); + if inc then + Gen0(pc_adq) + else + Gen0(pc_sbq); + end; + cgReal,cgDouble,cgComp,cgExtended: begin GenLdcReal(1.0); if inc then @@ -2406,7 +2414,7 @@ var if iType^.kind = scalarType then begin iSize := 1; baseType := iType^.baseType; - if (baseType in [cgReal,cgDouble,cgComp,cgExtended]) + if (baseType in [cgReal,cgDouble,cgComp,cgExtended,cgQuad,cgUQuad]) or (iType^.cType = ctBool) then begin {do real or bool inc or dec} @@ -2438,6 +2446,10 @@ var IncOrDec(pc_l = pc_lld); if iType^.cType = ctBool then expressionType := boolPtr + else if baseType = cgQuad then + expressionType := longLongPtr + else if baseType = cgUQuad then + expressionType := ulongLongPtr else expressionType := doublePtr; goto 1; From 10cf6e446d02a5bf6fc5ecceb56497efc002700a Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 12:39:27 -0600 Subject: [PATCH 18/68] Enable automatic comparison with 0 for long longs. This allows them to be used in if statements and as controlling expressions for loops. --- Expression.pas | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Expression.pas b/Expression.pas index e807c8b..b914088 100644 --- a/Expression.pas +++ b/Expression.pas @@ -1757,6 +1757,8 @@ if expressionType^.kind = scalarType then begin Gen1t(pc_ldc, 0, cgWord); cgLong,cgULong: GenLdcLong(0); + cgQuad,cgUQuad: + GenLdcQuad(longlong0); cgReal,cgDouble,cgComp,cgExtended: GenLdcReal(0.0); otherwise: From 2408c9602c89f974a9b91dbd171b8cc133068c19 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 12:44:44 -0600 Subject: [PATCH 19/68] Make expressionValue a saturating approximation of the true value for long long expressions. This gives sensible behavior for several things in the parser, e.g. where all negative values or all very large values should be disallowed. --- CCommon.pas | 2 +- Expression.pas | 17 +++++++++++++++-- Parser.pas | 6 +++--- 3 files changed, 19 insertions(+), 6 deletions(-) diff --git a/CCommon.pas b/CCommon.pas index cad3a88..0c060da 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -491,7 +491,7 @@ var {------------------} doDispose: boolean; {dispose of the expression tree as we go?} realExpressionValue: double; {value of the last real constant expression} - longlongExpressionValue: longlong; {value of the last long long constant expression} + llExpressionValue: longlong; {value of the last long long constant expression} expressionValue: longint; {value of the last constant expression} expressionType: typePtr; {the type of the expression} initializerTree: tokenPtr; {for non-constant initializers} diff --git a/Expression.pas b/Expression.pas index b914088..9a801d0 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3899,6 +3899,8 @@ if kind = normalExpression then begin {generate code from the expression tree} else begin {record the expression for an initializer} initializerTree := tree; isConstant := false; + llExpressionValue.lo := 0; + llExpressionValue.hi := 0; if errorFound then begin DisposeTree(initializerTree); initializerTree := nil; @@ -3955,12 +3957,23 @@ else begin {record the expression for an initialize isConstant := true; end {else if} else if tree^.token.kind = longlongconst then begin - longlongExpressionValue := tree^.token.qval; + llExpressionValue := tree^.token.qval; + if ((llExpressionValue.hi = 0) and (llExpressionValue.lo >= 0)) + or ((llExpressionValue.hi = -1) and (llExpressionValue.lo < 0)) then + expressionValue := llExpressionValue.lo + else if llExpressionValue.hi < 0 then + expressionValue := $80000000 + else + expressionValue := $7fffffff; expressionType := longLongPtr; isConstant := true; end {else if} else if tree^.token.kind = ulonglongconst then begin - longlongExpressionValue := tree^.token.qval; + llExpressionValue := tree^.token.qval; + if llExpressionValue.hi = 0 then + expressionValue := llExpressionValue.lo + else + expressionValue := $FFFFFFFF; expressionType := ulongLongPtr; isConstant := true; end {else if} diff --git a/Parser.pas b/Parser.pas index 4c2e0c5..1addc76 100644 --- a/Parser.pas +++ b/Parser.pas @@ -1947,7 +1947,7 @@ var if isConstant and (variable^.storage in [external,global,private]) then begin if bitsize = 0 then begin if etype^.baseType in [cgQuad,cgUQuad] then begin - iPtr^.qVal := longlongExpressionValue; + iPtr^.qVal := llExpressionValue; end {if} else begin iPtr^.qval.hi := 0; @@ -2031,8 +2031,8 @@ var errorFound := true; end {else} else if etype^.baseType in [cgQuad,cgUQuad] then - if (longlongExpressionValue.hi = 0) and - (longlongExpressionValue.lo = 0) then + if (llExpressionValue.hi = 0) and + (llExpressionValue.lo = 0) then iPtr^.iType := cgULong else begin Error(47); From 5e5434987b0c6974ccf59afa60d62de194b62db0 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 14:56:15 -0600 Subject: [PATCH 20/68] Give an error when trying to evaluate constant expressions with long long operands. --- Expression.pas | 7 +++++++ Scanner.pas | 1 + 2 files changed, 8 insertions(+) diff --git a/Expression.pas b/Expression.pas index 9a801d0..ec5228a 100644 --- a/Expression.pas +++ b/Expression.pas @@ -1058,6 +1058,10 @@ var op^.left := Pop; kindRight := op^.right^.token.kind; kindLeft := op^.left^.token.kind; + if not (kind in [normalExpression,autoInitializerExpression]) then + if (kindLeft in [longlongconst,ulonglongconst]) + or (kindRight in [longlongconst,ulonglongconst]) then + Error(157); if kindRight in [intconst,uintconst,longconst,ulongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst] then begin if kind = preprocessorExpression then begin @@ -1378,6 +1382,9 @@ var else if not (op^.token.kind in [typedef,plusplusop,minusminusop,opplusplus,opminusminus,uand]) then begin + if not (kind in [normalExpression,autoInitializerExpression]) then + if op^.left^.token.kind in [longlongconst,ulonglongconst] then + Error(157); if (op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst]) then begin diff --git a/Scanner.pas b/Scanner.pas index 96e807a..b5026cc 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -687,6 +687,7 @@ if list or (numErr <> 0) then begin 154: msg := @'lint: function declared _Noreturn can return or has unreachable code'; 155: msg := @'lint: non-void function may not return a value or has unreachable code'; 156: msg := @'invalid suffix on numeric constant'; + 157: msg := @'ORCA/C cannot evaluate this constant expression with long long operand(s)'; otherwise: Error(57); end; {case} writeln(msg^); From d2fb8cc27eb32a1eb6aae839c0280a1976261b49 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 17:53:10 -0600 Subject: [PATCH 21/68] Add long long support for the ! operator. --- Expression.pas | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Expression.pas b/Expression.pas index ec5228a..0c22708 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3685,6 +3685,11 @@ case tree^.token.kind of Gen0t(pc_equ, cgLong); end; + cgQuad,cgUQuad: begin + GenLdcQuad(longlong0); + Gen0t(pc_equ, cgQuad); + end; + cgExtended: begin GenLdcReal(0.0); Gen0t(pc_equ, cgExtended); From fc3bd32e65e1d62a1cc508728a746903d1913403 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 17:53:37 -0600 Subject: [PATCH 22/68] Add long long support for a couple lint checks. --- Expression.pas | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Expression.pas b/Expression.pas index 0c22708..c9941e1 100644 --- a/Expression.pas +++ b/Expression.pas @@ -2828,7 +2828,8 @@ var begin {CheckDivByZero} if opType^.kind = scalarType then - if opType^.baseType in [cgByte,cgWord,cgUByte,cgUWord,cgLong,cgULong] then + if opType^.baseType in + [cgByte,cgWord,cgUByte,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then if ((divisor.class = intConstant) and (divisor.ival = 0)) or ((divisor.class = longConstant) and (divisor.lval = 0)) or ((divisor.class = longlongConstant) @@ -2870,6 +2871,9 @@ var if opType^.baseType in [cgLong,cgULong] then if (shiftCount < 0) or (shiftCount > 31) then Error(130); + if opType^.baseType in [cgQuad,cgUQuad] then + if (shiftCount < 0) or (shiftCount > 63) then + Error(130); end; {if} end; {CheckShiftOverflow} From 8992ddc11f659219e7dc6254baea79f255e4df62 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 18:32:06 -0600 Subject: [PATCH 23/68] Implement indirect store/copy operations for 64-bit types. These operations (pc_sto and pc_cpi) are used for access through a pointer, and in some cases also for initialization. --- Gen.pas | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/Gen.pas b/Gen.pas index 20a8389..d639bb2 100644 --- a/Gen.pas +++ b/Gen.pas @@ -3664,6 +3664,43 @@ case optype of end; {else} end; {case cgReal,cgDouble,cgComp,cgExtended} + cgQuad,cgUQuad: begin + GenTree(op^.right); + gLong.preference := A_X; + GenTree(op^.left); + if gLong.where = onStack then begin + GenImplied(m_pla); + GenImplied(m_plx); + end; {if} + GenNative(m_sta_dir, direct, dworkLoc, nil, 0); + GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_indl, direct, dworkLoc, nil, 0); + GenNative(m_ldy_imm, immediate, 2, nil, 0); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + GenImplied(m_iny); + GenImplied(m_iny); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + GenImplied(m_iny); + GenImplied(m_iny); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + end; {case cgQuad,cgUQuad} + cgLong,cgULong: begin if opcode = pc_sto then gLong.preference := onStack+constant From 7f3ba768cd9fbee4ceb83cd986623d0dd9d7c5d1 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 22:05:02 -0600 Subject: [PATCH 24/68] Allow pointer arithmetic using long long values. This converts them to 32-bit values before doing computations, which is (more than) sufficient for address calculations on the 65816. Trying to compute an address outside the legal range is undefined behavior, and does not necessarily "wrap around" in a predictable way. --- Expression.pas | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Expression.pas b/Expression.pas index c9941e1..50f2f46 100644 --- a/Expression.pas +++ b/Expression.pas @@ -2122,10 +2122,12 @@ case tp of Gen0(op); end; end; - cgLong,cgULong: begin + cgLong,cgULong,cgQuad,cgUQuad: begin + if tp in [cgQuad,cgUQuad] then + Gen2(pc_cnv, ord(tp), ord(cgLong)); if size <> 1 then begin GenLdcLong(size); - if tp = cgLong then + if tp in [cgLong,cgQuad] then Gen0(pc_mpl) else Gen0(pc_uml); From 08cf7a0181e97a58dd53acad66e5c5030d51d185 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 4 Feb 2021 22:23:59 -0600 Subject: [PATCH 25/68] Implement 64-bit multiplication support. Signed multiplication uses the existing ~MUL8 routine in SysLib. Unsigned multiplication will use a new ~UMUL8 library routine. --- CGI.Comments | 4 ++++ CGI.Debug | 2 ++ CGI.pas | 2 +- DAG.pas | 10 ++++++---- Expression.pas | 8 ++++++++ Gen.pas | 7 ++++++- Native.pas | 2 ++ 7 files changed, 29 insertions(+), 6 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index 7f18cb1..573cb45 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -480,12 +480,16 @@ { pc_umi - unsigned integer multiply } { pc_mpl - long integer multiply } { pc_uml - unsigned long multiply } +{ pc_mpq - long long integer multiply } +{ pc_umq - unsigned long long multiply } { pc_mpr - real multiply } { } { Gen0(pc_mpi) cgByte,cgWord } { Gen0(pc_umi) cgUByte,cgUWord } { Gen0(pc_mpl) cgLong } { Gen0(pc_uml) cgULong } +{ Gen0(pc_mpq) cgQuad } +{ Gen0(pc_umq) cgUQuad } { Gen0(pc_mpr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } diff --git a/CGI.Debug b/CGI.Debug index c4a8e26..82ba67d 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -121,6 +121,8 @@ opt[pc_bqx] := 'bqx'; opt[pc_baq] := 'baq'; opt[pc_bnq] := 'bnq'; opt[pc_ngq] := 'ngq'; +opt[pc_mpq] := 'mpq'; +opt[pc_umq] := 'umq'; end; {InitWriteCode} diff --git a/CGI.pas b/CGI.pas index 3bffb45..75a3357 100644 --- a/CGI.pas +++ b/CGI.pas @@ -229,7 +229,7 @@ type 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_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq,pc_mpq,pc_umq); {intermediate code} {-----------------} diff --git a/DAG.pas b/DAG.pas index 8af07b9..0a68635 100644 --- a/DAG.pas +++ b/DAG.pas @@ -110,7 +110,8 @@ function CodesMatch (op1, op2: icptr; exact: boolean): boolean; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor, pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi, - pc_umi, pc_mpl, pc_uml, pc_mpr, pc_bqr, pc_bqx, pc_baq, pc_adq: begin + pc_umi, pc_mpl, pc_uml, pc_mpr, pc_bqr, pc_bqx, pc_baq, pc_adq, + pc_mpq, pc_umq: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; @@ -2266,7 +2267,7 @@ case op^.opcode of pc_udl, pc_ulm, pc_uml, pc_vsr: TypeOf := cgULong; - pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq: + pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq, pc_mpq, pc_umq: TypeOf := cgQuad; pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: @@ -4062,7 +4063,8 @@ var pc_mdl,pc_ulm,pc_mpi,pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi, pc_ngl,pc_ngr,pc_not,pc_pop,pc_sbi,pc_sbl,pc_sbr, pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri, - pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq] + pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq, + pc_mpq,pc_umq] then begin op^.parents := icount; icount := icount+1; @@ -4943,7 +4945,7 @@ case code^.opcode of pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq, pc_adq, - pc_sbq: + pc_sbq, pc_mpq, pc_umq: begin code^.right := Pop; code^.left := Pop; diff --git a/Expression.pas b/Expression.pas index 50f2f46..727ce83 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3142,6 +3142,10 @@ case tree^.token.kind of Gen0(pc_mpl) else if et = cgULong then Gen0(pc_uml) + else if et = cgQuad then + Gen0(pc_mpq) + else if et = cgUQuad then + Gen0(pc_umq) else if et = cgExtended then Gen0(pc_mpr) else @@ -3556,6 +3560,10 @@ case tree^.token.kind of Gen0(pc_mpl); cgULong: Gen0(pc_uml); + cgQuad: + Gen0(pc_mpq); + cgUQuad: + Gen0(pc_umq); cgExtended: Gen0(pc_mpr); otherwise: diff --git a/Gen.pas b/Gen.pas index d639bb2..065dc46 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4524,6 +4524,11 @@ procedure GenTree {op: icptr}; pc_bqr: GenOp(m_ora_s); pc_bqx: GenOp(m_eor_s); pc_baq: GenOp(m_and_s); + + pc_mpq: GenCall(79); + + pc_umq: GenCall(80); + otherwise: Error(cge1); end; {case} end; {GenBinQuad} @@ -6128,7 +6133,7 @@ case op^.opcode of pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, pc_uml,pc_vsr: GenBinLong(op); - pc_bqr,pc_bqx,pc_baq: GenBinQuad(op); + pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq: GenBinQuad(op); pc_bnl,pc_ngl: GenUnaryLong(op); pc_bnq,pc_ngq: GenUnaryQuad(op); pc_bno: GenBno(op); diff --git a/Native.pas b/Native.pas index 77262eb..362213a 100644 --- a/Native.pas +++ b/Native.pas @@ -2033,6 +2033,8 @@ case callNum of 76: sp := @'~STACKERR'; {CC} 77: sp := @'~LOADSTRUCT'; {CC} 78: sp := @'~DIV4'; {CC} + 79: sp := @'~MUL8'; + 80: sp := @'~UMUL8'; otherwise: Error(cge1); end; {case} From 05868667b204c93d0e82de7aa01c3be9db1ad4e7 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 5 Feb 2021 12:42:48 -0600 Subject: [PATCH 26/68] Implement 64-bit division and remainder, signed and unsigned. These operations rely on new library routines in ORCALib (~CDIV8 and ~UDIV8). --- CGI.Comments | 8 ++++++++ CGI.Debug | 4 ++++ CGI.pas | 3 ++- DAG.pas | 7 ++++--- Expression.pas | 16 ++++++++++++++++ Gen.pas | 46 ++++++++++++++++++++++++++++++++++++++++++++-- Native.pas | 2 ++ 7 files changed, 80 insertions(+), 6 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index 573cb45..dead7e6 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -275,12 +275,16 @@ { pc_udi - unsigned integer divide } { pc_dvl - long integer divide } { pc_udl - unsigned long divide } +{ pc_dvq - long long integer divide } +{ pc_udq - unsigned long long divide } { pc_dvr - real divide } { } { Gen0(pc_dvi) cgByte,cgWord } { Gen0(pc_udi) cgUByte,cgUWord } { Gen0(pc_dvl) cgLong } { Gen0(pc_udl) cgULong } +{ Gen0(pc_dvq) cgQuad } +{ Gen0(pc_udq) cgUQuad } { Gen0(pc_dvr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } @@ -464,11 +468,15 @@ { pc_uim - unsigned integer modulus/remainder } { pc_mdl - long remainder } { pc_ulm - unsigned long modulus/remainder } +{ pc_mdq - long long remainder } +{ pc_uqm - unsigned long long modulus/remainder } { } { Gen0(pc_mod) cgByte,cgWord } { Gen0(pc_uim) cgUByte,cgUWord } { Gen0(pc_mdl) cgLong } { Gen0(pc_ulm) cgULong } +{ Gen0(pc_mdq) cgQuad } +{ Gen0(pc_uqm) cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and the remainder after division is calculated. } diff --git a/CGI.Debug b/CGI.Debug index 82ba67d..fc52fe6 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -123,6 +123,10 @@ opt[pc_bnq] := 'bnq'; opt[pc_ngq] := 'ngq'; opt[pc_mpq] := 'mpq'; opt[pc_umq] := 'umq'; +opt[pc_dvq] := 'dvq'; +opt[pc_udq] := 'udq'; +opt[pc_mdq] := 'mdq'; +opt[pc_uqm] := 'uqm'; end; {InitWriteCode} diff --git a/CGI.pas b/CGI.pas index 75a3357..6dec193 100644 --- a/CGI.pas +++ b/CGI.pas @@ -229,7 +229,8 @@ type 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_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); {intermediate code} {-----------------} diff --git a/DAG.pas b/DAG.pas index 0a68635..a8128c7 100644 --- a/DAG.pas +++ b/DAG.pas @@ -2267,7 +2267,8 @@ case op^.opcode of pc_udl, pc_ulm, pc_uml, pc_vsr: TypeOf := cgULong; - pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq, pc_mpq, pc_umq: + pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq, pc_mpq, + pc_umq, pc_dvq, pc_udq, pc_mdq, pc_uqm: TypeOf := cgQuad; pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: @@ -4064,7 +4065,7 @@ var pc_ngl,pc_ngr,pc_not,pc_pop,pc_sbi,pc_sbl,pc_sbr, pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri, pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq, - pc_mpq,pc_umq] + pc_mpq,pc_umq,pc_dvq,pc_udq,pc_mdq,pc_uqm] then begin op^.parents := icount; icount := icount+1; @@ -4945,7 +4946,7 @@ case code^.opcode of pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq, pc_adq, - pc_sbq, pc_mpq, pc_umq: + pc_sbq, pc_mpq, pc_umq, pc_dvq, pc_udq, pc_mdq, pc_uqm: begin code^.right := Pop; code^.left := Pop; diff --git a/Expression.pas b/Expression.pas index 727ce83..07535b3 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3160,6 +3160,10 @@ case tree^.token.kind of Gen0(pc_dvl) else if et = cgULong then Gen0(pc_udl) + else if et = cgQuad then + Gen0(pc_dvq) + else if et = cgUQuad then + Gen0(pc_udq) else if et = cgExtended then Gen0(pc_dvr) else @@ -3174,6 +3178,10 @@ case tree^.token.kind of Gen0(pc_mdl) else if et = cgULong then Gen0(pc_ulm) + else if et = cgQuad then + Gen0(pc_mdq) + else if et = cgUQuad then + Gen0(pc_uqm) else Error(66); @@ -3586,6 +3594,10 @@ case tree^.token.kind of Gen0(pc_dvl); cgULong: Gen0(pc_udl); + cgQuad: + Gen0(pc_dvq); + cgUQuad: + Gen0(pc_udq); cgExtended: Gen0(pc_dvr); otherwise: @@ -3610,6 +3622,10 @@ case tree^.token.kind of Gen0(pc_mdl); cgULong: Gen0(pc_ulm); + cgQuad: + Gen0(pc_mdq); + cgUQuad: + Gen0(pc_uqm); otherwise: error(66); end; {case} diff --git a/Gen.pas b/Gen.pas index 065dc46..12c1bb7 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4493,7 +4493,8 @@ procedure GenTree {op: icptr}; procedure GenBinQuad (op: icptr); - { generate one of: pc_bqr, pc_bqx, pc_baq } + { generate one of: pc_bqr, pc_bqx, pc_baq, pc_mpq, pc_umq, } + { pc_dvq, pc_udq, pc_mdq, pc_uqm } procedure GenOp (ops: integer); @@ -4529,6 +4530,46 @@ procedure GenTree {op: icptr}; pc_umq: GenCall(80); + pc_dvq: begin + GenCall(81); {do division} + GenImplied(m_pla); {get quotient, discarding remainder} + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + end; + + pc_udq: begin + GenCall(82); {do division} + GenImplied(m_pla); {get quotient, discarding remainder} + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + end; + + pc_mdq: begin + GenCall(81); {do division} + GenImplied(m_tsc); {discard quotient, leaving remainder} + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; + + pc_uqm: begin + GenCall(82); {do division} + GenImplied(m_tsc); {discard quotient, leaving remainder} + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; + otherwise: Error(cge1); end; {case} end; {GenBinQuad} @@ -6133,7 +6174,8 @@ case op^.opcode of pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, pc_uml,pc_vsr: GenBinLong(op); - pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq: GenBinQuad(op); + pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq,pc_dvq,pc_udq,pc_mdq,pc_uqm: + GenBinQuad(op); pc_bnl,pc_ngl: GenUnaryLong(op); pc_bnq,pc_ngq: GenUnaryQuad(op); pc_bno: GenBno(op); diff --git a/Native.pas b/Native.pas index 362213a..4088d9d 100644 --- a/Native.pas +++ b/Native.pas @@ -2035,6 +2035,8 @@ case callNum of 78: sp := @'~DIV4'; {CC} 79: sp := @'~MUL8'; 80: sp := @'~UMUL8'; + 81: sp := @'~CDIV8'; + 82: sp := @'~UDIV8'; otherwise: Error(cge1); end; {case} From 11938d51ff1820626ca88856494982b2033d853e Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 5 Feb 2021 20:52:03 -0600 Subject: [PATCH 27/68] Compute how many bytes of arguments are passed to a function. This is preparatory to supporting a new calling convention for functions returning long long. --- Gen.pas | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/Gen.pas b/Gen.pas index 12c1bb7..222c13e 100644 --- a/Gen.pas +++ b/Gen.pas @@ -67,6 +67,7 @@ var namePushed: boolean; {has a name been pushed in this proc?} skipLoad: boolean; {skip load for a pc_lli, etc?} stackSaveDepth: integer; {nesting depth of saved stack positions} + argsSize: integer; {total size of argument to a function} {stack frame locations} {---------------------} @@ -4627,6 +4628,7 @@ procedure GenTree {op: icptr}; var lab1: integer; {return point} lLong: longType; {used to reserve gLong} + lArgsSize: integer; {saved copy of argsSize} begin {GenCui} {save the stack register} @@ -4640,6 +4642,9 @@ procedure GenTree {op: icptr}; stackSaveDepth := stackSaveDepth + 1; end; {if} + lArgsSize := argsSize; + argsSize := 0; + {generate parameters} {place the operands on the stack} lLong := gLong; @@ -4697,6 +4702,7 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; SaveRetValue(op^.optype); + argsSize := lArgsSize; end; {GenCui} @@ -4705,7 +4711,8 @@ procedure GenTree {op: icptr}; { Generate code for a pc_cup } var - lLong: longType; {used to reserve gLong} + lLong: longType; {used to reserve gLong} + lArgsSize: integer; {saved copy of argsSize} begin {GenCup} {save the stack register} @@ -4719,6 +4726,9 @@ procedure GenTree {op: icptr}; stackSaveDepth := stackSaveDepth + 1; end; {if} + lArgsSize := argsSize; + argsSize := 0; + {generate parameters} lLong := gLong; GenTree(op^.left); @@ -4755,6 +4765,7 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; SaveRetValue(op^.optype); + argsSize := lArgsSize; end; {GenCup} @@ -5948,7 +5959,26 @@ procedure GenTree {op: icptr}; var lab1: integer; {branch point} - begin {GenStk} + begin {GenStk} + if op^.left^.opcode = pc_psh then begin + if (op^.left^.right^.opcode = pc_ldc) and + (op^.left^.right^.optype in [cgWord,cgUWord]) then + argsSize := argsSize + op^.left^.right^.q + else + Error(cge1); + end {if} + else + case op^.optype of + cgByte,cgUByte,cgWord,cgUWord: + argsSize := argsSize + cgWordSize; + cgReal,cgDouble,cgComp,cgExtended: + argsSize := argsSize + cgExtendedSize; + cgLong,cgULong: + argsSize := argsSize + cgLongSize; + cgQuad,cgUQuad: + argsSize := argsSize + cgQuadSize; + otherwise: Error(cge1); + end; {case} glong.preference := onStack; {generate the operand} GenTree(op^.left); if op^.optype in {do the stk} From 47fdd9e37013a8deae031ffe7eff029b3f9c12d2 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 5 Feb 2021 21:30:03 -0600 Subject: [PATCH 28/68] Implement support for functions returning (unsigned) long long. These use a new calling convention specific to functions returning these types. When such functions are called, the caller must set the X register to the address within bank 0 that the return value is to be saved to. The function is then responsible for saving it there before returning to the caller. Currently, the calling code always makes space for the return value on the stack and sets X to point to that. (As an optimization, it would be possible to have the return value written directly to a local variable on the direct page, with no change needed to the function being called, but that has not yet been implemented.) --- Gen.pas | 75 +++++++++++++++++++++++++++++++++++++++++++++++++----- Parser.pas | 10 ++++++-- 2 files changed, 76 insertions(+), 9 deletions(-) diff --git a/Gen.pas b/Gen.pas index 222c13e..e5505a4 100644 --- a/Gen.pas +++ b/Gen.pas @@ -68,6 +68,7 @@ var skipLoad: boolean; {skip load for a pc_lli, etc?} stackSaveDepth: integer; {nesting depth of saved stack positions} argsSize: integer; {total size of argument to a function} + isQuadFunction: boolean; {is the return type cg(U)Quad?} {stack frame locations} {---------------------} @@ -4629,22 +4630,33 @@ procedure GenTree {op: icptr}; lab1: integer; {return point} lLong: longType; {used to reserve gLong} lArgsSize: integer; {saved copy of argsSize} + extraStackSize: integer; {size of extra stuff pushed on stack} begin {GenCui} + lArgsSize := argsSize; + argsSize := 0; + extraStackSize := 0; + + {For functions returning cg(U)Quad, make space for result} + if op^.optype in [cgQuad,cgUQuad] then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} + {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin if stackSaveDepth <> 0 then begin GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_phx); + extraStackSize := 2; end; {if} GenImplied(m_tsx); GenNative(m_stx_dir, direct, stackLoc, nil, 0); stackSaveDepth := stackSaveDepth + 1; end; {if} - lArgsSize := argsSize; - argsSize := 0; - {generate parameters} {place the operands on the stack} lLong := gLong; @@ -4654,6 +4666,14 @@ procedure GenTree {op: icptr}; gLong.preference := onStack; GenTree(op^.right); gLong := lLong; + + {For functions returning cg(U)Quad, x = address to store result in} + if op^.optype in [cgQuad,cgUQuad] then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, argsSize+extraStackSize+4+1, nil, 0); + GenImplied(m_tax); + end; {if} {create a return label} lab1 := GenLabel; @@ -4713,27 +4733,56 @@ procedure GenTree {op: icptr}; var lLong: longType; {used to reserve gLong} lArgsSize: integer; {saved copy of argsSize} + extraStackSize: integer; {size of extra stuff pushed on stack} begin {GenCup} + lArgsSize := argsSize; + argsSize := 0; + extraStackSize := 0; + + {For functions returning cg(U)Quad, make space for result} + if op^.optype in [cgQuad,cgUQuad] then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} + {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin if stackSaveDepth <> 0 then begin GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_phx); + extraStackSize := 2; end; {if} GenImplied(m_tsx); GenNative(m_stx_dir, direct, stackLoc, nil, 0); stackSaveDepth := stackSaveDepth + 1; end; {if} - lArgsSize := argsSize; - argsSize := 0; - {generate parameters} lLong := gLong; GenTree(op^.left); gLong := lLong; + {For functions returning cg(U)Quad, x = address to store result in} + if op^.optype in [cgQuad,cgUQuad] then + if argsSize + extraStackSize in [0,1,2] then begin + GenImplied(m_tsx); + GenImplied(m_inx); + if argsSize + extraStackSize in [1,2] then begin + GenImplied(m_inx); + if argsSize + extraStackSize = 2 then + GenImplied(m_inx); + end; {if} + end {if} + else begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, argsSize+extraStackSize+1, nil, 0); + GenImplied(m_tax); + end; {else} + {generate the jsl} GenNative(m_jsl, longAbs, 0, op^.lab, 0); @@ -4865,6 +4914,11 @@ procedure GenTree {op: icptr}; GenImplied(m_tcd); end; {if} + if isQuadFunction then begin {save return location for cg(U)Quad} + GenNative(m_stx_dir, direct, funloc, nil, 0); + GenNative(m_stz_dir, direct, funloc+2, nil, 0); + end; {if} + if dataBank then begin {preserve and set data bank} GenImplied(m_phb); GenImplied(m_phb); @@ -5841,6 +5895,8 @@ procedure GenTree {op: icptr}; GenNative(m_ldy_dir, direct, funLoc, nil, 0); end; + cgQuad,cgUQuad: ; {return value was already written} + otherwise: Error(cge1); end; {case} @@ -5883,7 +5939,7 @@ procedure GenTree {op: icptr}; end; {if} end; - cgVoid: ; + cgVoid,cgQuad,cgUQuad: ; otherwise: Error(cge1); @@ -6351,6 +6407,10 @@ var cgComp: size := cgCompSize; cgExtended: size := cgExtendedSize; cgLong,cgULong: size := cgLongSize; + cgQuad,cgUQuad: begin + size := cgLongSize; {pointer} + isQuadFunction := true; + end; end; {case} funLoc := 1; if dworkLoc <> 0 then @@ -6379,6 +6439,7 @@ funLoc := 0; dworkLoc := 0; minSize := 1; stackSaveDepth := 0; +isQuadFunction := false; while bk <> nil do begin op := bk^.code; while op <> nil do begin diff --git a/Parser.pas b/Parser.pas index 1addc76..3dd0015 100644 --- a/Parser.pas +++ b/Parser.pas @@ -751,12 +751,18 @@ var id := FindSymbol(tk, variableSpace, false, true); Gen1Name(pc_lao, 0, id^.name); size := fType^.size; - end; {if} + end {if} + else if fType^.kind = scalarType then + if fType^.baseType in [cgQuad,cgUQuad] then + Gen2t(pc_lod, 0, 0, cgULong); Expression(normalExpression, [semicolonch]); AssignmentConversion(fType, expressionType, lastWasConst, lastConst, true, false); case fType^.kind of - scalarType: Gen2t(pc_str, 0, 0, fType^.baseType); + scalarType: if fType^.baseType in [cgQuad,cgUQuad] then + Gen0t(pc_sto, fType^.baseType) + else + Gen2t(pc_str, 0, 0, fType^.baseType); enumType: Gen2t(pc_str, 0, 0, cgWord); pointerType: Gen2t(pc_str, 0, 0, cgULong); structType, From 446639badc9134d589e5bad1a392bed194adbe03 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 6 Feb 2021 12:45:44 -0600 Subject: [PATCH 29/68] Don't bogusly push stuff on the stack for conversions to non-long types. This could happen in some cases when converting between signed and unsigned long long (which should not require any code to be generated). --- Gen.pas | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/Gen.pas b/Gen.pas index e5505a4..d643513 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1177,8 +1177,8 @@ const {note: these constants list all legal } cComp = $08; cExtended = $09; cVoid = $0B; - cQuad = $0C; - cUQuad = $0D; + cLong = $04; + cULong = $05; byteToWord = $02; byteToUword = $03; @@ -1579,17 +1579,18 @@ else if op^.q in [quadToReal, uquadToReal] then Error(cge1) {TODO: implement} else if (op^.q & $000F) = cVoid then {do nothing} -else if lLong.preference & gLong.where = 0 then begin - if gLong.where = constant then begin - GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); - GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); - end {if} - else if gLong.where = A_X then begin - GenImplied(m_phx); - GenImplied(m_pha); - end; {else if} - gLong.where := onStack; - end; {else if} +else if (op^.q & $000F) in [cLong,cULong] then + if (lLong.preference & gLong.where) = 0 then begin + if gLong.where = constant then begin + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end {if} + else if gLong.where = A_X then begin + GenImplied(m_phx); + GenImplied(m_pha); + end; {else if} + gLong.where := onStack; + end; {if} end; {GenCnv} From 30f2eda4f3ece75747423e80e3adc91b45bf196d Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 11 Feb 2021 12:41:58 -0600 Subject: [PATCH 30/68] Generate code for long long to real conversions. --- Gen.pas | 6 ++++-- Native.pas | 2 ++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Gen.pas b/Gen.pas index d643513..ee44442 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1575,8 +1575,10 @@ else if op^.q in [quadToVoid,uquadToVoid] then begin GenNative(m_adc_imm, immediate, 8, nil, 0); GenImplied(m_tcs); end {else if} -else if op^.q in [quadToReal, uquadToReal] then - Error(cge1) {TODO: implement} +else if op^.q = quadToReal then + GenCall(83) +else if op^.q = uquadToReal then + GenCall(84) else if (op^.q & $000F) = cVoid then {do nothing} else if (op^.q & $000F) in [cLong,cULong] then diff --git a/Native.pas b/Native.pas index 4088d9d..eaf39be 100644 --- a/Native.pas +++ b/Native.pas @@ -2037,6 +2037,8 @@ case callNum of 80: sp := @'~UMUL8'; 81: sp := @'~CDIV8'; 82: sp := @'~UDIV8'; + 83: sp := @'~CNVLONGLONGREAL'; + 84: sp := @'~CNVULONGLONGREAL'; otherwise: Error(cge1); end; {case} From cb97623878b0d1977a50f84d73b2ab698317fdec Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 11 Feb 2021 18:53:25 -0600 Subject: [PATCH 31/68] Do not copy CGI.Comments into CGI.pas. This has no functional effect, since it is all comments. It does mean that printed listings of CGI.pas would not contain those comments, but it is easy enough to restore if someone wants such listings. This change should make compilation slightly faster, and it also avoids issues with filetypes when using certain tools (since they cannot infer the filetype of CGI.Comments from its extension). --- CGI.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CGI.pas b/CGI.pas index 6dec193..8ff4901 100644 --- a/CGI.pas +++ b/CGI.pas @@ -11,7 +11,7 @@ { passed on to the code generator for optimization and } { native code generation. } { } -{$copy 'cgi.comments'} +{ copy 'cgi.comments'} {---------------------------------------------------------------} unit CodeGeneratorInterface; From 00d72f04d3806cd1b884d512d6f1a2e4aca1a468 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 11 Feb 2021 19:47:42 -0600 Subject: [PATCH 32/68] Implement basic peephole optimizations for some 64-bit operations. This currently covers bitwise ops, addition, and subtraction. --- DAG.pas | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 85 insertions(+) diff --git a/DAG.pas b/DAG.pas index b15eab6..de20aef 100644 --- a/DAG.pas +++ b/DAG.pas @@ -876,6 +876,15 @@ case op^.opcode of {check for optimizations of this node} end; {else} end; {case pc_adr} + pc_adq: begin {pc_adq} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_adq} + pc_and: begin {pc_and} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin @@ -910,6 +919,24 @@ case op^.opcode of {check for optimizations of this node} end; {else if} end; {case pc_bal} + pc_baq: begin {pc_baq} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi & op^.right^.qval.hi; + op^.left^.qval.lo := op^.left^.qval.lo & op^.right^.qval.lo; + opv := op^.left; + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then begin + if not SideEffects(op^.left) then + opv := op^.right; + end {if} + else if (op^.right^.qval.lo = -1) and (op^.right^.qval.hi = -1) then + opv := op^.left; + end; {else if} + end; {case pc_baq} + pc_blr: begin {pc_blr} if op^.left^.opcode = pc_ldc then ReverseChildren(op); @@ -927,6 +954,24 @@ case op^.opcode of {check for optimizations of this node} end; {else if} end; {case pc_blr} + pc_bqr: begin {pc_bqr} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi | op^.right^.qval.hi; + op^.left^.qval.lo := op^.left^.qval.lo | op^.right^.qval.lo; + opv := op^.left; + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.hi = -1) and (op^.right^.qval.lo = -1) then begin + if not SideEffects(op^.left) then + opv := op^.right; + end {if} + else if (op^.right^.qval.hi = 0) and (op^.right^.qval.lo = 0) then + opv := op^.left; + end; {else if} + end; {case pc_bqr} + pc_blx: begin {pc_blx} if op^.left^.opcode = pc_ldc then ReverseChildren(op); @@ -944,6 +989,24 @@ case op^.opcode of {check for optimizations of this node} end; {else if} end; {case pc_blx} + pc_bqx: begin {pc_bqx} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi ! op^.right^.qval.hi; + op^.left^.qval.lo := op^.left^.qval.lo ! op^.right^.qval.lo; + opv := op^.left; + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left + else if (op^.right^.qval.lo = -1) and (op^.right^.qval.hi = -1) then begin + op^.opcode := pc_bnq; + op^.right := nil; + end; {else if} + end; {else if} + end; {case pc_bqx} + pc_bnd: begin {pc_bnd} if op^.left^.opcode = pc_ldc then ReverseChildren(op); @@ -968,6 +1031,14 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_bnl} + pc_bnq: begin {pc_bnq} + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi ! $FFFFFFFF; + op^.left^.qval.lo := op^.left^.qval.lo ! $FFFFFFFF; + opv := op^.left; + end; {if} + end; {case pc_bnq} + pc_bno: begin {pc_bno} {Invalid optimization disabled} {if op^.left^.opcode = pc_str then @@ -2013,6 +2084,20 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_sbr} + pc_sbq: begin {pc_sbq} + if op^.left^.opcode = pc_ldc then begin + if (op^.left^.qval.lo = 0) and (op^.left^.qval.hi = 0) then begin + op^.opcode := pc_ngq; + op^.left := op^.right; + op^.right := nil; + end; {else if} + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_sbq} + pc_shl: begin {pc_shl} if op^.right^.opcode = pc_ldc then begin opcode := op^.left^.opcode; From 8faafcc7c84d0c9a007d4462d5ff90bc2b355327 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 12 Feb 2021 15:06:15 -0600 Subject: [PATCH 33/68] Implement 64-bit shifts. --- CGI.Comments | 13 +++++++++++-- CGI.pas | 2 +- DAG.pas | 8 ++++++-- Expression.pas | 47 ++++++++++++++++++++++++++++++++++++++--------- Gen.pas | 10 ++++++++-- Native.pas | 3 +++ 6 files changed, 67 insertions(+), 16 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index dead7e6..b5e0ab6 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -576,25 +576,32 @@ { } { pc_shl - shift left } { pc_sll - shift left long } +{ pc_slq - shift left long long } { } { Gen0(pc_shl) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_sll) cgLong,cgULong } +{ Gen0(pc_slq) cgQuad,cgUQuad (tos-1) / cgWord (tos) } { } { The value at tos-1 is shifted left by the number of bits } { specified by tos. The result is an integer, which replaces } { the operands on the stack. The right bit positions are } -{ filled with zeros. } +{ filled with zeros. For pc_slq, only the value at tos-1 is } +{ cgQuad/cgUQuad; the shift count at tos is cgWord or cgUWord. } { } { } { pc_shr - shift right } { pc_usr - unsigned shift right } { pc_slr - long shift right } { pc_vsr - unsigned long shift right } +{ pc_sqr - long long shift right } +{ pc_wsr - unsigned long long shift right } { } { Gen0(pc_shr) cgByte,cgWord } { Gen0(pc_usr) cgUByte,cgUWord } { Gen0(pc_slr) cgLong } { Gen0(pc_vsr) cgULong } +{ Gen0(pc_sqr) cgQuad (tos-1) / cgWord (tos) } +{ Gen0(pc_wsr) cgUQuad (tos-1) / cgWord (tos) } { } { The value at tos-1 is shifted right by the number of bits } { specified by tos. The result is an integer, which replaces } @@ -604,7 +611,9 @@ { } { Pc_usr is the unsigned form. The operation is the same, } { except that the leftmost bit is replaced with a zero. } -{ Pc_vsr is used for unsigned long operations. } +{ Pc_vsr is used for unsigned long operations, and pc_wsr is } +{ used for unsigned long long operations. } +{ } { } { pc_stk - stack an operand } { } diff --git a/CGI.pas b/CGI.pas index 8ff4901..a3d7e26 100644 --- a/CGI.pas +++ b/CGI.pas @@ -230,7 +230,7 @@ type 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_udq,pc_mdq,pc_uqm,pc_slq,pc_sqr,pc_wsr); {intermediate code} {-----------------} diff --git a/DAG.pas b/DAG.pas index de20aef..24df823 100644 --- a/DAG.pas +++ b/DAG.pas @@ -2385,9 +2385,12 @@ case op^.opcode of TypeOf := cgULong; pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq, pc_mpq, - pc_umq, pc_dvq, pc_udq, pc_mdq, pc_uqm: + pc_dvq, pc_mdq, pc_slq, pc_sqr: TypeOf := cgQuad; + pc_umq, pc_udq, pc_uqm, pc_wsr: + TypeOf := cgUQuad; + pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: TypeOf := cgExtended; @@ -5063,7 +5066,8 @@ case code^.opcode of pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq, pc_adq, - pc_sbq, pc_mpq, pc_umq, pc_dvq, pc_udq, pc_mdq, pc_uqm: + pc_sbq, pc_mpq, pc_umq, pc_dvq, pc_udq, pc_mdq, pc_uqm, pc_slq, + pc_sqr, pc_wsr: begin code^.right := Pop; code^.left := Pop; diff --git a/Expression.pas b/Expression.pas index 07535b3..942c5d8 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3090,10 +3090,17 @@ case tree^.token.kind of [cgReal,cgDouble,cgComp,cgExtended,cgVoid] then Error(66); et := UsualUnaryConversions; - if et <> Unary(ltype^.baseType) then begin - Gen2(pc_cnv, et, ord(Unary(ltype^.baseType))); + if ltype^.baseType in [cgQuad,cgUQuad] then begin + if not (et in [cgWord,cgUWord]) then begin + Gen2(pc_cnv, et, ord(cgWord)); + end; {if} expressionType := lType; - end; {if} + end {if} + else + if et <> Unary(ltype^.baseType) then begin + Gen2(pc_cnv, et, ord(Unary(ltype^.baseType))); + expressionType := lType; + end; {if} end; {if} if kind <> pointerType then et := UsualBinaryConversions(lType) @@ -3190,6 +3197,8 @@ case tree^.token.kind of Gen0(pc_shl) else if et in [cgLong,cgULong] then Gen0(pc_sll) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_slq) else Error(66); @@ -3202,6 +3211,10 @@ case tree^.token.kind of Gen0(pc_slr) else if et = cgULong then Gen0(pc_vsr) + else if et = cgQuad then + Gen0(pc_sqr) + else if et = cgUQuad then + Gen0(pc_wsr) else Error(66); @@ -3399,15 +3412,22 @@ case tree^.token.kind of GenerateCode(tree^.right); if (expressionType^.kind <> scalarType) or not (expressionType^.baseType in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong]) then + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]) then error(66); - if expressionType^.baseType <> et then - Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); + if et in [cgQuad,cgUQuad] then begin + if not (expressionType^.baseType in [cgWord,cgUWord]) then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(cgWord)); + end {if} + else + if expressionType^.baseType <> et then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); case et of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_shl); cgLong,cgULong: Gen0(pc_sll); + cgQuad,cgUQuad: + Gen0(pc_slq); otherwise: error(66); end; {case} @@ -3425,10 +3445,15 @@ case tree^.token.kind of GenerateCode(tree^.right); if (expressionType^.kind <> scalarType) or not (expressionType^.baseType in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong]) then + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]) then error(66); - if expressionType^.baseType <> et then - Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); + if et in [cgQuad,cgUQuad] then begin + if not (expressionType^.baseType in [cgWord,cgUWord]) then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(cgWord)); + end {if} + else + if expressionType^.baseType <> et then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); case et of cgByte,cgWord: Gen0(pc_shr); @@ -3438,6 +3463,10 @@ case tree^.token.kind of Gen0(pc_slr); cgULong: Gen0(pc_vsr); + cgQuad: + Gen0(pc_sqr); + cgUQuad: + Gen0(pc_wsr); otherwise: error(66); end; {case} diff --git a/Gen.pas b/Gen.pas index ee44442..451c289 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4575,6 +4575,12 @@ procedure GenTree {op: icptr}; GenImplied(m_tcs); end; + pc_slq: GenCall(85); + + pc_sqr: GenCall(86); + + pc_wsr: GenCall(87); + otherwise: Error(cge1); end; {case} end; {GenBinQuad} @@ -6263,8 +6269,8 @@ case op^.opcode of pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, pc_uml,pc_vsr: GenBinLong(op); - pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq,pc_dvq,pc_udq,pc_mdq,pc_uqm: - GenBinQuad(op); + pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq,pc_dvq,pc_udq,pc_mdq,pc_uqm,pc_slq, + pc_sqr,pc_wsr: GenBinQuad(op); pc_bnl,pc_ngl: GenUnaryLong(op); pc_bnq,pc_ngq: GenUnaryQuad(op); pc_bno: GenBno(op); diff --git a/Native.pas b/Native.pas index eaf39be..6922009 100644 --- a/Native.pas +++ b/Native.pas @@ -2039,6 +2039,9 @@ case callNum of 82: sp := @'~UDIV8'; 83: sp := @'~CNVLONGLONGREAL'; 84: sp := @'~CNVULONGLONGREAL'; + 85: sp := @'~SHL8'; + 86: sp := @'~ASHR8'; + 87: sp := @'~LSHR8'; otherwise: Error(cge1); end; {case} From a3050c76a9f9f53457be82563c0ad23033a8c115 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 15:07:16 -0600 Subject: [PATCH 34/68] Evaluate some kinds of long long operations in constant expressions. Other operations on long long (e.g. arithmetic) are still not supported in constant expressions. --- Expression.pas | 170 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 163 insertions(+), 7 deletions(-) diff --git a/Expression.pas b/Expression.pas index 942c5d8..e984d5a 100644 --- a/Expression.pas +++ b/Expression.pas @@ -901,6 +901,7 @@ var op: tokenPtr; {work pointer} op1,op2: longint; {for evaluating constant expressions} rop1,rop2: double; {for evaluating double expressions} + llop1, llop2: longlong; {for evaluating long long expressions} tp: typePtr; {cast type} unsigned: boolean; {is the term unsigned?} @@ -969,6 +970,39 @@ var end; {IntVal} + procedure GetLongLongVal (var result: longlong; token: tokenType); + + { convert an operand to a long long value } + + begin {LongLongVal} + if token.kind = intconst then begin + result.lo := token.ival; + if result.lo < 0 then + result.hi := -1 + else + result.hi := 0; + end {if} + else if token.kind = uintconst then begin + result.lo := token.ival & $0000FFFF; + result.hi := 0; + end {else if} + else if token.kind = longconst then begin + result.lo := token.lval; + if result.lo < 0 then + result.hi := -1 + else + result.hi := 0; + end {else if} + else if token.kind = ulongconst then begin + result.lo := token.lval; + result.hi := 0; + end {else if} + else {if token.kind in [longlongconst,ulonglongconst] then} begin + result := token.qval; + end; {else} + end; {LongLongVal} + + function PPKind (token: tokenType): tokenEnum; { adjust kind of token for use in preprocessor expression } @@ -1058,10 +1092,6 @@ var op^.left := Pop; kindRight := op^.right^.token.kind; kindLeft := op^.left^.token.kind; - if not (kind in [normalExpression,autoInitializerExpression]) then - if (kindLeft in [longlongconst,ulonglongconst]) - or (kindRight in [longlongconst,ulonglongconst]) then - Error(157); if kindRight in [intconst,uintconst,longconst,ulongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst] then begin if kind = preprocessorExpression then begin @@ -1200,6 +1230,90 @@ var goto 1; end; {if} end; {if} + if kindRight in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst] then begin + if kindLeft in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst] then begin + + if kind = preprocessorExpression then begin + kindLeft := PPKind(op^.left^.token); + kindRight := PPKind(op^.right^.token); + end; {if} + + {do the usual binary conversions} + if (kindRight = ulonglongconst) or (kindLeft = ulonglongconst) then + ekind := ulonglongconst + else + ekind := longlongconst; + + GetLongLongVal(llop1, op^.left^.token); + GetLongLongVal(llop2, op^.right^.token); + dispose(op^.right); + op^.right := nil; + dispose(op^.left); + op^.left := nil; + + case op^.token.kind of + barbarop : begin {||} + op1 := ord((llop1.lo <> 0) or (llop1.hi <> 0) or + (llop2.lo <> 0) or (llop2.hi <> 0)); + ekind := intconst; + end; + andandop : begin {&&} + op1 := ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and + ((llop2.lo <> 0) or (llop2.hi <> 0))); + ekind := intconst; + end; + carotch : begin {^} + llop1.lo := llop1.lo ! llop2.lo; + llop1.hi := llop1.hi ! llop2.hi; + end; + barch : begin {|} + llop1.lo := llop1.lo | llop2.lo; + llop1.hi := llop1.hi | llop2.hi; + end; + andch : begin {&} + llop1.lo := llop1.lo & llop2.lo; + llop1.hi := llop1.hi & llop2.hi; + end; + eqeqop : begin {==} + op1 := ord((llop1.lo = llop2.lo) and + (llop1.hi = llop2.hi)); + ekind := intconst; + end; + exceqop : begin {!=} + op1 := ord((llop1.lo <> llop2.lo) or + (llop1.hi <> llop2.hi)); + ekind := intconst; + end; + ltch, {<} + gtch, {>} + lteqop, {<=} + gteqop, {>=} + ltltop, {<<} + gtgtop, {>>} + plusch, {+} + minusch, {-} + asteriskch, {*} + slashch, {/} + percentch: {%} + if not (kind in [normalExpression,autoInitializerExpression]) + then + Error(157); + otherwise: Error(57); + end; {case} + op^.token.kind := ekind; + if ekind in [longlongconst,ulonglongconst] then begin + op^.token.qval := llop1; + op^.token.class := longlongConstant; + end {if} + else begin + op^.token.ival := long(op1).lsw; + op^.token.class := intConstant; + end; {else} + goto 1; + end; {if} + end; {if} if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst,doubleconst] then if op^.left^.token.kind in @@ -1262,7 +1376,15 @@ var op^.token.class := doubleConstant; op^.token.kind := doubleConst; end; {else} + goto 1; end; {if} + if op^.right^.token.kind in [intconst,uintconst,longconst, + ulongconst,longlongconst,ulonglongconst,doubleconst] then + if op^.left^.token.kind in [intconst,uintconst,longconst, + ulongconst,longlongconst,ulonglongconst,doubleconst] then + if not (kind in [normalExpression,autoInitializerExpression]) + then + Error(157); 1: end; @@ -1382,9 +1504,6 @@ var else if not (op^.token.kind in [typedef,plusplusop,minusminusop,opplusplus,opminusminus,uand]) then begin - if not (kind in [normalExpression,autoInitializerExpression]) then - if op^.left^.token.kind in [longlongconst,ulonglongconst] then - Error(157); if (op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst]) then begin @@ -1415,6 +1534,43 @@ var op^.token.ival := long(op1).lsw; end; {else} end {if} + else if op^.left^.token.kind + in [longlongconst,ulonglongconst] then begin + + {evaluate a constant operation} + ekind := op^.left^.token.kind; + llop1 := op^.left^.token.qval; + dispose(op^.left); + op^.left := nil; + case op^.token.kind of + tildech : begin {~} + llop1.lo := ~llop1.lo; + llop1.hi := ~llop1.hi; + end; + excch : begin {!} + op1 := ord((llop1.hi = 0) and (llop1.lo = 0)); + ekind := intconst; + end; + uminus : begin {unary -} + llop1.lo := ~llop1.lo; + llop1.hi := ~llop1.hi; + llop1.lo := llop1.lo + 1; + if llop1.lo = 0 then + llop1.hi := llop1.hi + 1; + end; + uasterisk : Error(79); {unary *} + otherwise: Error(57); + end; {case} + op^.token.kind := ekind; + if ekind in [longlongconst,ulonglongconst] then begin + op^.token.class := longlongConstant; + op^.token.qval := llop1; + end {if} + else begin + op^.token.class := intConstant; + op^.token.ival := long(op1).lsw; + end; {else} + end {else if} else if op^.left^.token.kind = doubleconst then begin ekind := doubleconst; {evaluate a constant operation} rop1 := RealVal(op^.left^.token); From 32ae4c2e171e70292bbe9b86aa52bc80763a2ac1 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 15:36:54 -0600 Subject: [PATCH 35/68] Allow unsigned constants in "address+constant" constant expressions. This affected initializers like the following: static int a[50]; static int *ip = &a[0] + 2U; Also, introduce some basic range checks for calculations that are obviously outside the 65816's address space. --- Parser.pas | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/Parser.pas b/Parser.pas index 3dd0015..13f194a 100644 --- a/Parser.pas +++ b/Parser.pas @@ -1852,8 +1852,13 @@ var size := rtree^.token.ival else if rtree^.token.kind in [longconst,ulongconst] then size := rtree^.token.lval - else if rtree^.token.kind in [longlongconst,ulonglongconst] then - size := rtree^.token.qval.lo + else if rtree^.token.kind in [longlongconst,ulonglongconst] then begin + size := rtree^.token.qval.lo; + with rtree^.token.qval do + if not (((hi = 0) and (lo & $ff000000 = 0)) or + ((hi = -1) and (lo & $ff000000 = $ff000000))) then + Error(6); + end {else if} else begin Error(18); errorFound := true; @@ -2085,13 +2090,25 @@ var operator := tree^.token.kind; while operator in [plusch,minusch] do begin with tree^.right^.token do - if kind in [intConst,longConst,longlongConst] then begin + if kind in [intConst,uintconst,longConst,ulongconst, + longlongConst,ulonglongconst] then begin if kind = intConst then offSet2 := ival - else if kind = longConst then - offset2 := lval - else {if kind = longlongConst then} + else if kind = uintConst then + offset2 := ival & $0000ffff + else if kind in [longConst,ulongconst] then begin + offset2 := lval; + if (lval & $ff000000 <> 0) + and (lval & $ff000000 <> $ff000000) then + Error(6); + end {else if} + else {if kind = longlongConst then} begin offset2 := qval.lo; + with qval do + if not (((hi = 0) and (lo & $ff000000 = 0)) or + ((hi = -1) and (lo & $ff000000 = $ff000000))) then + Error(6); + end; {else} if operator = plusch then offset := offset + offset2 else From 75234dbf83abf165e2cc3c339cf34205f0038f41 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 17:03:49 -0600 Subject: [PATCH 36/68] Handle long long in pc_equ/pc_neq optimizations. --- DAG.pas | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/DAG.pas b/DAG.pas index 24df823..1ababf9 100644 --- a/DAG.pas +++ b/DAG.pas @@ -1404,6 +1404,13 @@ case op^.opcode of {check for optimizations of this node} op^.left := nil; op^.right := nil; end; + cgQuad,cgUQuad: begin + op^.opcode := pc_ldc; + op^.q := ord((op^.left^.qval.lo = op^.right^.qval.lo) and + (op^.left^.qval.hi = op^.right^.qval.hi)); + op^.left := nil; + op^.right := nil; + end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval = op^.right^.rval); @@ -1845,6 +1852,13 @@ case op^.opcode of {check for optimizations of this node} op^.left := nil; op^.right := nil; end; + cgQuad,cgUQuad: begin + op^.opcode := pc_ldc; + op^.q := ord((op^.left^.qval.lo <> op^.right^.qval.lo) or + (op^.left^.qval.hi <> op^.right^.qval.hi)); + op^.left := nil; + op^.right := nil; + end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval <> op^.right^.rval); From f41cd241f86a5eb06463958ba5a35649eea364ee Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 17:21:13 -0600 Subject: [PATCH 37/68] Slightly optimize stack save code for calls to long long functions. The X register is not used as part of the return value, so it does not have to be preserved. --- Gen.pas | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/Gen.pas b/Gen.pas index 451c289..d43d03a 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4716,11 +4716,13 @@ procedure GenTree {op: icptr}; end {if} else if saveStack or (op^.q <> 0) then begin stackSaveDepth := stackSaveDepth - 1; - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_txy); GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_txs); - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_tyx); if stackSaveDepth <> 0 then begin GenImplied(m_ply); @@ -4808,11 +4810,13 @@ procedure GenTree {op: icptr}; end {if} else if saveStack or (op^.q <> 0) then begin stackSaveDepth := stackSaveDepth - 1; - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_txy); GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_txs); - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_tyx); if stackSaveDepth <> 0 then begin GenImplied(m_ply); From c48811add681f1d910aed569b5e3649920701848 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 18:46:00 -0600 Subject: [PATCH 38/68] Report errors in a few cases where the codegen finds unexpected types. This makes it more likely that unsupported ops on long long or any other types added in the future will give an error rather than silently generating bad code. Also, update a comment. --- CGI.Comments | 3 ++- Gen.pas | 12 ++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/CGI.Comments b/CGI.Comments index b5e0ab6..7142d91 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -421,9 +421,10 @@ { } { Gen1t(pc_ldc, val, type) } { GenLdcLong(val) } +{ GenLdcQuad(val) } { GenLdcReal(val) } { } -{ Loads a constant value. Special calls for long and real } +{ Loads a constant value. Special calls for long, quad & real } { values are provided due to the unique parameter requirements.} { } { } diff --git a/Gen.pas b/Gen.pas index d43d03a..f4136c2 100644 --- a/Gen.pas +++ b/Gen.pas @@ -2461,7 +2461,9 @@ else if op^.optype in [cgLong,cgULong] then begin end; {else} end; {else} end; {else} - end; {else if} + end {else if} +else + Error(cge1); end; {GenIncDec} @@ -2682,7 +2684,7 @@ case optype of end; {if} end; {case cgByte,cgUByte,cgWord,cgUWord} - otherwise: ; + otherwise: Error(cge1); end; {case} end; {GenInd} @@ -4252,7 +4254,7 @@ case optype of end; {else} end; - otherwise: ; + otherwise: Error(cge1); end; {case} end; {GenStrCop} @@ -5691,7 +5693,9 @@ procedure GenTree {op: icptr}; if isIncLoad then skipLoad := false; case op^.optype of {do the pop} - otherwise: ; + otherwise: Error(cge1); + + cgByte, cgUByte, cgWord, cgUWord, cgVoid: ; cgLong, cgULong: if not isIncLoad then From e8b860f89ab2d71e6877d8ae60137cff373b3780 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 21:14:26 -0600 Subject: [PATCH 39/68] Do not corrupt long long expressions that cannot be evaluated at compile time. The changes to constant expressions were not allowing the unsupported constant expressions to be evaluated at run time when they appear in regular code. --- Expression.pas | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/Expression.pas b/Expression.pas index e984d5a..7eebcf1 100644 --- a/Expression.pas +++ b/Expression.pas @@ -1230,6 +1230,7 @@ var goto 1; end; {if} end; {if} + if kindRight in [intconst,uintconst,longconst,ulongconst, longlongconst,ulonglongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst, @@ -1248,10 +1249,6 @@ var GetLongLongVal(llop1, op^.left^.token); GetLongLongVal(llop2, op^.right^.token); - dispose(op^.right); - op^.right := nil; - dispose(op^.left); - op^.left := nil; case op^.token.kind of barbarop : begin {||} @@ -1296,12 +1293,22 @@ var minusch, {-} asteriskch, {*} slashch, {/} - percentch: {%} - if not (kind in [normalExpression,autoInitializerExpression]) - then - Error(157); + percentch: begin {%} + if kind in [normalExpression,autoInitializerExpression] + then goto 1; + Error(157); + llop1 := longlong0; + op1 := 0; + if op^.token.kind in [ltch,gtch,lteqop,gteqop] then + ekind := intconst; + end; otherwise: Error(57); end; {case} + + dispose(op^.right); + op^.right := nil; + dispose(op^.left); + op^.left := nil; op^.token.kind := ekind; if ekind in [longlongconst,ulonglongconst] then begin op^.token.qval := llop1; @@ -1314,6 +1321,7 @@ var goto 1; end; {if} end; {if} + if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst,doubleconst] then if op^.left^.token.kind in @@ -1378,6 +1386,7 @@ var end; {else} goto 1; end; {if} + if op^.right^.token.kind in [intconst,uintconst,longconst, ulongconst,longlongconst,ulonglongconst,doubleconst] then if op^.left^.token.kind in [intconst,uintconst,longconst, From c537153ee5c9cd8bd84d9e18762fcbd636dcc518 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 13 Feb 2021 21:42:06 -0600 Subject: [PATCH 40/68] Implement pc_ind (load indirect) for long long. --- Gen.pas | 164 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 164 insertions(+) diff --git a/Gen.pas b/Gen.pas index f4136c2..1c4f3be 100644 --- a/Gen.pas +++ b/Gen.pas @@ -2684,6 +2684,170 @@ case optype of end; {if} end; {case cgByte,cgUByte,cgWord,cgUWord} + cgQuad,cgUQuad: begin + GetPointer(op^.left); + if gLong.where = inPointer then begin + if q = 0 then begin + if gLong.fixedDisp then begin + GenNative(m_ldy_imm, immediate, 6, nil, 0); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_indl, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + end {if} + else begin + GenImplied(m_tya); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 6, nil, 0); + GenImplied(m_tay); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + end; {else} + end {if q = 0} + else begin + if gLong.fixedDisp then begin + GenNative(m_ldy_imm, immediate, q+6, nil, 0); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + end {if} + else begin + GenImplied(m_tya); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, q+6, nil, 0); + GenImplied(m_tay); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + end; {else} + end; {else} + end {if glong.where = inPointer} + else if gLong.where = localAddress then begin + gLong.disp := gLong.disp+q; + if gLong.fixedDisp then + if (gLong.disp < 250) and (gLong.disp >= 0) then begin + GenNative(m_pei_dir, direct, gLong.disp+6, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp+4, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp+2, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp, nil, 0); + end {if} + else begin + GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); + GenNative(m_lda_dirX, direct, 6, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, 4, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, 2, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, 0, nil, 0); + GenImplied(m_pha); + end {else} + else begin + if (gLong.disp >= 250) or (gLong.disp < 0) then begin + GenImplied(m_txa); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); + GenImplied(m_tax); + gLong.disp := 0; + end; {if} + GenNative(m_lda_dirX, direct, gLong.disp+6, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, gLong.disp+4, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, gLong.disp+2, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + end; {else} + end {else if gLong.where = localAddress} + else {if gLong.where = globalLabel then} begin + gLong.disp := gLong.disp+q; + if gLong.fixedDisp then + if smallMemoryModel then begin + GenNative(m_lda_abs, absolute, gLong.disp+6, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_abs, absolute, gLong.disp+4, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_abs, absolute, gLong.disp+2, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0); + GenImplied(m_pha); + end {if} + else begin + GenNative(m_lda_long, longAbs, gLong.disp+6, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_long, longAbs, gLong.disp+4, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0); + GenImplied(m_pha); + end {else} + else + if smallMemoryModel then begin + GenNative(m_lda_absX, absolute, gLong.disp+6, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_absX, absolute, gLong.disp+4, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_absX, absolute, gLong.disp+2, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0); + GenImplied(m_pha); + end {if} + else begin + GenNative(m_lda_longX, longAbs, gLong.disp+6, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_longX, longAbs, gLong.disp+4, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0); + GenImplied(m_pha); + end; {else} + end; {else} + end; {case cgQuad,cgUQuad} otherwise: Error(cge1); end; {case} end; {GenInd} From eb49e10ea97e85a5995765777048fb6f25ce13fb Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 14 Feb 2021 17:37:55 -0600 Subject: [PATCH 41/68] Implement && and || operators for long long types. This is done by comparing against 0 (similar to how it is done for reals), rather than introducing new intermediate code operations. --- Expression.pas | 72 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 52 insertions(+), 20 deletions(-) diff --git a/Expression.pas b/Expression.pas index 7eebcf1..8090004 100644 --- a/Expression.pas +++ b/Expression.pas @@ -3460,20 +3460,36 @@ case tree^.token.kind of GenerateCode(tree^.left); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} lType := expressionType; GenerateCode(tree^.right); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_ior); @@ -3489,20 +3505,36 @@ case tree^.token.kind of GenerateCode(tree^.left); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} lType := expressionType; GenerateCode(tree^.right); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_and); From 76cc4b9ca704d579ee0547face4b1427d9af94d2 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 14 Feb 2021 17:42:54 -0600 Subject: [PATCH 42/68] Update printf/scanf format checker to match recent library changes. *Recognize the 'll' and 'j' size modifiers as denoting long long times. *Recognize '%P' as equivalent to '%b'. *Give a warning for 'L' length modifier in scanf, which is currently not supported (except when assignment is suppressed). --- Printf.pas | 58 +++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 47 insertions(+), 11 deletions(-) diff --git a/Printf.pas b/Printf.pas index 9ba63d1..dbfa30f 100644 --- a/Printf.pas +++ b/Printf.pas @@ -49,9 +49,10 @@ implementation const feature_hh = true; - feature_ll = false; + feature_ll = true; feature_s_long = false; feature_n_size = true; + feature_scanf_ld = false; type length_modifier = (default, h, hh, l, ll, j, z, t, ld); @@ -252,6 +253,24 @@ var end; {expect_long} + procedure expect_long_long; + { Verify the current argument is a long long int.} + var + ty: typePtr; + + begin {expect_long_long} + ty := popType; + if ty <> nil then begin + if (ty^.kind <> scalarType) or (not (ty^.baseType in [cgQuad, cgUQuad])) then begin + Warning(@'expected long long int'); + end; {if} + end {if} + else begin + Warning(@'argument missing; expected long long int'); + end; {else} + end; {expect_long_long} + + procedure expect_int; var ty: typePtr; @@ -456,9 +475,9 @@ var has_suppress := true; end; - 'b': begin + 'b', 'P': begin if has_length <> default then - Warning(@'length modifier may not be used with %b'); + Warning(@'length modifier may not be used with %b or %P'); expected := [cgByte, cgUByte]; name := @'char'; end; @@ -489,10 +508,14 @@ var expected := [cgByte, cgUByte]; name := @'char'; end; - l, ll, j, z, t: begin + l, z, t: begin expected := [cgLong, cgULong]; name := @'long'; end; + ll, j: begin + expected := [cgQuad, cgUQuad]; + name := @'long long'; + end; h: begin expected := [cgWord, cgUWord]; name := @'short'; @@ -523,10 +546,14 @@ var expected := [cgByte, cgUByte]; name := @'char'; end; - l, ll, j, z, t: begin + l, z, t: begin expected := [cgLong, cgULong]; name := @'long'; end; + ll, j: begin + expected := [cgQuad, cgUQuad]; + name := @'long long'; + end; h: begin expected := [cgWord, cgUWord]; name := @'short'; @@ -552,6 +579,9 @@ var case has_length of ld: begin + if not feature_scanf_ld then + if not has_suppress then + Warning(@'L length modifier is not currently supported'); expected := [cgExtended]; name := @'long double'; end; @@ -606,7 +636,7 @@ var length_set := ['h', 'l', 'j', 't', 'z', 'L']; flag_set := ['#', '0', '-', '+', ' ']; format_set := ['%', '[', 'b', 'c', 's', 'd', 'i', 'o', 'x', 'X', 'u', - 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p']; + 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p', 'P']; for i := 1 to s^.length do begin @@ -711,9 +741,9 @@ var end; { %b: orca-specific - pascal string } - 'b': begin + 'b', 'P': begin if has_length <> default then - Warning(@'length modifier may not be used with %b'); + Warning(@'length modifier may not be used with %b or %P'); expect_pointer_to([cgByte, cgUByte], @'char'); end; @@ -739,9 +769,12 @@ var hh: expect_pointer_to([cgByte, cgUByte], @'char'); - l, ll, j, z, t: + l, z, t: expect_pointer_to([cgLong, cgULong], @'long'); + ll, j: + expect_pointer_to([cgQuad, cgUQuad], @'long long'); + otherwise: begin if feature_n_size and (has_length = ld) then Warning(@'invalid length modifier'); @@ -767,9 +800,12 @@ var { chars are passed as ints so %hhx can be ignored here. } 'd', 'i', 'o', 'x', 'X', 'u': - if has_length in [l, ll, j, z, t] then begin + if has_length in [l, z, t] then begin expect_long; end + else if has_length in [ll, j] then begin + expect_long_long; + end else if has_length = ld then begin Warning(@'invalid length modifier'); expect_int; @@ -805,7 +841,7 @@ var length_set := ['h', 'l', 'j', 't', 'z', 'L']; flag_set := ['#', '0', '-', '+', ' ']; format_set := ['%', 'b', 'c', 's', 'd', 'i', 'o', 'x', 'X', 'u', - 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p']; + 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p', 'P']; for i := 1 to s^.length do begin c := s^.str[i]; From d66f6b27b76dff20858d24258d728a807d1fe798 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 14 Feb 2021 20:39:22 -0600 Subject: [PATCH 43/68] Evaluate arithmetic and shifts in long long constant expressions. This winds up calling functions for these operations in ORCALib, so an up-to-date version of that must now be available to build the ORCA/C compiler. --- Exp.macros | 104 ++++++++++++++++++++ Expression.asm | 256 +++++++++++++++++++++++++++++++++++++++++++++++++ Expression.pas | 111 ++++++++++++++++----- 3 files changed, 446 insertions(+), 25 deletions(-) diff --git a/Exp.macros b/Exp.macros index 8d451b7..5b97682 100644 --- a/Exp.macros +++ b/Exp.macros @@ -162,3 +162,107 @@ LONGI OFF .I MEND + macro +&l ph8 &n1 + lclc &c +&l anop +&c amid &n1,1,1 + aif s:longa=1,.a + rep #%00100000 +.a + aif "&c"="#",.d + aif "&c"="[",.b + aif "&c"<>"{",.c +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.g +&n1 amid &n1,2,l:&n1-2 +&n1 setc (&n1) +.b + ldy #6 +~&SYSCNT lda &n1,y + pha + dey + dey + bpl ~&SYSCNT + ago .e +.c + ldx #6 +~&SYSCNT lda &n1,x + pha + dex + dex + bpl ~&SYSCNT + ago .e +.d +&n1 amid &n1,2,l:&n1-1 + bra ~b&SYSCNT +~a&SYSCNT dc i8"&n1" +~b&SYSCNT ldx #6 +~c&SYSCNT lda ~a&SYSCNT,x + pha + dex + dex + bpl ~c&SYSCNT +.e + aif s:longa=1,.f + sep #%00100000 +.f + mexit +.g + mnote "Missing closing '}'",16 + mend + macro +&l pl8 &n1 + lclc &c +&l anop + aif s:longa=1,.a + rep #%00100000 +.a +&c amid &n1,1,1 + aif "&c"<>"{",.b +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.f +&n1 amid &n1,2,l:&n1-2 + pla + sta (&n1) + ldy #2 + pla + sta (&n1),y + ldy #4 + pla + sta (&n1),y + ldy #6 + pla + sta (&n1),y + ago .d +.b + aif "&c"<>"[",.c + pla + sta &n1 + ldy #2 + pla + sta &n1,y + ldy #4 + pla + sta &n1,y + ldy #6 + pla + sta &n1,y + ago .d +.c + pla + sta &n1 + pla + sta &n1+2 + pla + sta &n1+4 + pla + sta &n1+6 +.d + aif s:longa=1,.e + sep #%00100000 +.e + mexit +.f + mnote "Missing closing '}'",16 + mend diff --git a/Expression.asm b/Expression.asm index 378ff8d..db8fd2b 100644 --- a/Expression.asm +++ b/Expression.asm @@ -382,3 +382,259 @@ ml6 ror a shift the answer ; ml7 return 4:ans fix the stack end + +**************************************************************** +* +* procedure umul64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +umul64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~UMUL8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure udiv64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +udiv64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~UDIV8 + pl8 [x] + pla + pla + pla + pla + + return + end + +**************************************************************** +* +* procedure div64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +div64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~CDIV8 + pl8 [x] + pla + pla + pla + pla + + return + end + +**************************************************************** +* +* procedure umod64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +umod64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~UDIV8 + pla + pla + pla + pla + pl8 [x] + + return + end + +**************************************************************** +* +* procedure rem64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +rem64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~CDIV8 + pla + pla + pla + pla + pl8 [x] + + return + end + +**************************************************************** +* +* procedure add64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +add64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~ADD8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure sub64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +sub64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~SUB8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure shl64 (var x: longlong; y: integer); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +shl64 start exp + + subroutine (4:x,2:y),0 + + ph8 [x] + lda y + jsl ~SHL8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure ashr64 (var x: longlong; y: integer); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +ashr64 start exp + + subroutine (4:x,2:y),0 + + ph8 [x] + lda y + jsl ~ASHR8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure lshr64 (var x: longlong; y: integer); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +lshr64 start exp + + subroutine (4:x,2:y),0 + + ph8 [x] + lda y + jsl ~LSHR8 + pl8 [x] + + return + end diff --git a/Expression.pas b/Expression.pas index 8090004..a0cd7fa 100644 --- a/Expression.pas +++ b/Expression.pas @@ -269,6 +269,29 @@ function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; +{-- External 64-bit math routines ------------------------------} +{ Procedures for arithmetic and shifts compute "x := x OP y". } + +procedure umul64 (var x: longlong; y: longlong); extern; + +procedure udiv64 (var x: longlong; y: longlong); extern; + +procedure div64 (var x: longlong; y: longlong); extern; + +procedure umod64 (var x: longlong; y: longlong); extern; + +procedure rem64 (var x: longlong; y: longlong); extern; + +procedure add64 (var x: longlong; y: longlong); extern; + +procedure sub64 (var x: longlong; y: longlong); extern; + +procedure shl64 (var x: longlong; y: integer); extern; + +procedure ashr64 (var x: longlong; y: integer); extern; + +procedure lshr64 (var x: longlong; y: integer); extern; + {---------------------------------------------------------------} function Unary(tp: baseTypeEnum): baseTypeEnum; @@ -1247,18 +1270,23 @@ var else ekind := longlongconst; + unsigned := ekind = ulonglongconst; GetLongLongVal(llop1, op^.left^.token); GetLongLongVal(llop2, op^.right^.token); case op^.token.kind of barbarop : begin {||} - op1 := ord((llop1.lo <> 0) or (llop1.hi <> 0) or - (llop2.lo <> 0) or (llop2.hi <> 0)); + llop1.hi := 0; + llop1.lo := + ord((llop1.lo <> 0) or (llop1.hi <> 0) or + (llop2.lo <> 0) or (llop2.hi <> 0)); ekind := intconst; end; andandop : begin {&&} - op1 := ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and - ((llop2.lo <> 0) or (llop2.hi <> 0))); + llop1.hi := 0; + llop1.lo := + ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and + ((llop2.lo <> 0) or (llop2.hi <> 0))); ekind := intconst; end; carotch : begin {^} @@ -1274,34 +1302,63 @@ var llop1.hi := llop1.hi & llop2.hi; end; eqeqop : begin {==} - op1 := ord((llop1.lo = llop2.lo) and - (llop1.hi = llop2.hi)); + llop1.hi := 0; + llop1.lo := ord((llop1.lo = llop2.lo) and + (llop1.hi = llop2.hi)); ekind := intconst; end; exceqop : begin {!=} - op1 := ord((llop1.lo <> llop2.lo) or - (llop1.hi <> llop2.hi)); + llop1.hi := 0; + llop1.lo := ord((llop1.lo <> llop2.lo) or + (llop1.hi <> llop2.hi)); ekind := intconst; end; ltch, {<} gtch, {>} lteqop, {<=} - gteqop, {>=} - ltltop, {<<} - gtgtop, {>>} - plusch, {+} - minusch, {-} - asteriskch, {*} - slashch, {/} - percentch: begin {%} - if kind in [normalExpression,autoInitializerExpression] - then goto 1; - Error(157); - llop1 := longlong0; - op1 := 0; - if op^.token.kind in [ltch,gtch,lteqop,gteqop] then - ekind := intconst; - end; + gteqop : begin {>=} + if kind in [normalExpression,autoInitializerExpression] + then goto 1; + Error(157); + llop1 := longlong0; + op1 := 0; + if op^.token.kind in [ltch,gtch,lteqop,gteqop] then + ekind := intconst; + end; + ltltop : begin {<<} + shl64(llop1, long(llop2.lo).lsw); + ekind := kindLeft; + end; + gtgtop : begin {>>} + if kindleft = ulonglongconst then + lshr64(llop1, long(llop2.lo).lsw) + else + ashr64(llop1, long(llop2.lo).lsw); + ekind := kindLeft; + end; + plusch : add64(llop1, llop2); {+} + minusch : sub64(llop1, llop2); {-} + asteriskch : umul64(llop1, llop2); {*} + slashch : begin {/} + if (llop2.lo = 0) and (llop2.hi = 0) then begin + Error(109); + llop2 := longlong1; + end; {if} + if unsigned then + udiv64(llop1, llop2) + else + div64(llop1, llop2); + end; + percentch : begin {%} + if (llop2.lo = 0) and (llop2.hi = 0) then begin + Error(109); + llop2 := longlong1; + end; {if} + if unsigned then + umod64(llop1, llop2) + else + rem64(llop1, llop2); + end; otherwise: Error(57); end; {case} @@ -1314,8 +1371,12 @@ var op^.token.qval := llop1; op^.token.class := longlongConstant; end {if} + else if ekind in [longconst,ulongconst] then begin + op^.token.lval := llop1.lo; + op^.token.class := longConstant; + end {if} else begin - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; op^.token.class := intConstant; end; {else} goto 1; From 2e29390e8e9504019057df3b2ea8d5fb22c30656 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Mon, 15 Feb 2021 12:28:30 -0600 Subject: [PATCH 44/68] Support 64-bit decimal constants in code. --- Scanner.asm | 48 ++++++++++++++++++++++ Scanner.macros | 107 +++++++++++++++++++++++++++++++++++++++++++++++++ Scanner.pas | 16 +++++--- 3 files changed, 165 insertions(+), 6 deletions(-) diff --git a/Scanner.asm b/Scanner.asm index 805fa5b..9d25ffd 100644 --- a/Scanner.asm +++ b/Scanner.asm @@ -53,6 +53,54 @@ lb2 iny next character return 4:val end +**************************************************************** +* +* Convertsll - Convert a string to a long long integer +* +* Inputs: +* qval - pointer to location to save value +* str - pointer to the string +* +* Outputs: +* Saves the value to [qval]. +* +* Notes: +* Assumes the string is valid. +* +**************************************************************** +* +Convertsll start scanner +disp equ 0 displacement into the string +count equ 2 number of characters remaining to read + + subroutine (4:qval,4:str),4 + + lda [str] set count to length of string + and #$00FF + sta count + lda #1 start reading from character 1 + sta disp + ph8 #0 initialize the number to zero + bra lb1a +lb1 ph8 #10 multiply by 10 + jsl ~UMUL8 +lb1a pea $0000 + pea $0000 + pea $0000 + ldy disp + lda [str],Y add in the new digit + and #$000F + pha + jsl ~ADD8 +lb2 inc disp next character + dec count + bne lb1 + + pl8 [qval] save the value + + return + end + **************************************************************** * * KeyPress - Has a key been pressed? diff --git a/Scanner.macros b/Scanner.macros index 9bfff31..65bd74c 100644 --- a/Scanner.macros +++ b/Scanner.macros @@ -529,3 +529,110 @@ dc i4'&p' ~restm mend + macro +&l ph8 &n1 + lclc &c +&l anop +&c amid &n1,1,1 + aif s:longa=1,.a + rep #%00100000 +.a + aif "&c"="#",.d + aif "&c"="[",.b + aif "&c"<>"{",.c +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.g +&n1 amid &n1,2,l:&n1-2 +&n1 setc (&n1) +.b + ldy #6 +~&SYSCNT lda &n1,y + pha + dey + dey + bpl ~&SYSCNT + ago .e +.c + aif "&c"<>"<",.c1 + pei &n1+6 + pei &n1+4 + pei &n1+2 + pei &n1 + ago .e +.c1 + ldx #6 +~&SYSCNT lda &n1,x + pha + dex + dex + bpl ~&SYSCNT + ago .e +.d +&n1 amid &n1,2,l:&n1-1 + pea +(&n1)|-48 + pea +(&n1)|-32 + pea +(&n1)|-16 + pea &n1 +.e + aif s:longa=1,.f + sep #%00100000 +.f + mexit +.g + mnote "Missing closing '}'",16 + mend + macro +&l pl8 &n1 + lclc &c +&l anop + aif s:longa=1,.a + rep #%00100000 +.a +&c amid &n1,1,1 + aif "&c"<>"{",.b +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.f +&n1 amid &n1,2,l:&n1-2 + pla + sta (&n1) + ldy #2 + pla + sta (&n1),y + ldy #4 + pla + sta (&n1),y + ldy #6 + pla + sta (&n1),y + ago .d +.b + aif "&c"<>"[",.c + pla + sta &n1 + ldy #2 + pla + sta &n1,y + ldy #4 + pla + sta &n1,y + ldy #6 + pla + sta &n1,y + ago .d +.c + pla + sta &n1 + pla + sta &n1+2 + pla + sta &n1+4 + pla + sta &n1+6 +.d + aif s:longa=1,.e + sep #%00100000 +.e + mexit +.f + mnote "Missing closing '}'",16 + mend diff --git a/Scanner.pas b/Scanner.pas index b5026cc..8b3ebdb 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -414,6 +414,11 @@ function Convertsl(var str: pString): longint; extern; { Return the integer equivalent of the string. Assumes a valid } { 4-byte integer string; supports unsigned values. } +procedure Convertsll(var qval: longlong; var str: pString); extern; + +{ Save the integer equivalent of the string to qval. Assumes a } +{ valid 8-byte integer string; supports unsigned values. } + procedure SetDateTime; extern; @@ -3356,22 +3361,21 @@ else if numString[1] <> '0' then begin {convert a decimal integer} or (not unsigned and (stringIndex = 10) and (numString > '2147483647')) or (unsigned and (stringIndex = 10) and (numString > '4294967295')) then isLongLong := true; - if (stringIndex > 10) or {TODO increase limits} - ((stringIndex = 10) and (numString > '4294967295')) then begin + if (not unsigned and ((stringIndex > 19) or + ((stringIndex = 19) and (numString > '9223372036854775807')))) or + (unsigned and ((stringIndex > 20) or + ((stringIndex = 20) and (numString > '18446744073709551615')))) then begin numString := '0'; if flagOverflows then FlagError(6); end; {if} if isLongLong then begin token.class := longlongConstant; - token.qval.hi := 0; - token.qval.lo := Convertsl(numString); {TODO support full 64-bit range} + Convertsll(token.qval, numString); if unsigned then token.kind := ulonglongConst else begin token.kind := longlongConst; - if token.qval.hi < 0 then - FlagError(6); end; {else} end {if} else if isLong then begin From d2d871181a679181dd21883205edbe097c992a23 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Mon, 15 Feb 2021 14:43:26 -0600 Subject: [PATCH 45/68] Implement comparisons (>, >=, <, <=) for unsigned long long. --- Gen.pas | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/Gen.pas b/Gen.pas index 1c4f3be..5574239 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1160,6 +1160,57 @@ else end; {if} end; {case optype of cgLong} + cgUQuad: begin + GenTree(op^.left); + GenTree(op^.right); + if op^.opcode = pc_geq then + GenNative(m_ldx_imm, immediate, 1, nil, 0) + else {if op^.opcode = pc_grt then} + GenNative(m_ldx_imm, immediate, 0, nil, 0); + lab1 := GenLabel; + lab2 := GenLabel; + GenNative(m_lda_s, direct, 15, nil, 0); + GenNative(m_cmp_s, direct, 7, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 13, nil, 0); + GenNative(m_cmp_s, direct, 5, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 11, nil, 0); + GenNative(m_cmp_s, direct, 3, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 9, nil, 0); + GenNative(m_cmp_s, direct, 1, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenLab(lab1); + if op^.opcode = pc_geq then begin + GenNative(m_bcs, relative, lab2, nil, 0); + GenImplied(m_dex); + end {if} + else begin {if op^.opcode = pc_grt then} + GenNative(m_bcc, relative, lab2, nil, 0); + GenNative(m_beq, relative, lab2, nil, 0); + GenImplied(m_inx); + end; {else} + GenLab(lab2); + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 16, nil, 0); + GenImplied(m_tcs); + GenImplied(m_txa); + if rOpcode = pc_fjp then begin + lab3 := GenLabel; + GenNative(m_bne, relative, lab3, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab3); + end {if} + else if rOpcode = pc_tjp then begin + lab3 := GenLabel; + GenNative(m_beq, relative, lab3, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab3); + end; {else if} + end; {case optype of cgUQuad} + otherwise: Error(cge1); end; {case} From e38be489df06af5e70b206b73243009621a7167f Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Mon, 15 Feb 2021 18:10:10 -0600 Subject: [PATCH 46/68] Implement comparisons for signed long long. These use a library function to perform the comparison. --- Gen.pas | 31 +++++++++++++++++++++++++++++++ Native.pas | 1 + 2 files changed, 32 insertions(+) diff --git a/Gen.pas b/Gen.pas index 5574239..3d53abf 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1160,6 +1160,37 @@ else end; {if} end; {case optype of cgLong} + cgQuad: begin + if op^.opcode = pc_geq then begin + GenTree(op^.left); + GenTree(op^.right); + end {if} + else {if op^.opcode = pc_grt then} begin + GenTree(op^.right); + GenTree(op^.left); + end; {else} + GenCall(88); + if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin + lab1 := GenLabel; + if (rOpcode = pc_fjp) <> (op^.opcode = pc_grt) then + GenNative(m_bcs, relative, lab1, nil, 0) + else + GenNative(m_bcc, relative, lab1, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab1); + end {if} + else begin + lab1 := GenLabel; + GenNative(m_lda_imm, immediate, 1, nil, 0); + if op^.opcode = pc_geq then + GenNative(m_bcs, relative, lab1, nil, 0) + else + GenNative(m_bcc, relative, lab1, nil, 0); + GenImplied(m_dea); + GenLab(lab1); + end; {else} + end; {case optype of cgQuad} + cgUQuad: begin GenTree(op^.left); GenTree(op^.right); diff --git a/Native.pas b/Native.pas index 6922009..67a77d7 100644 --- a/Native.pas +++ b/Native.pas @@ -2042,6 +2042,7 @@ case callNum of 85: sp := @'~SHL8'; 86: sp := @'~ASHR8'; 87: sp := @'~LSHR8'; + 88: sp := @'~SCMP8'; otherwise: Error(cge1); end; {case} From e3b24fb50ba24599d8f70b212acd2148fa0dff08 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Tue, 16 Feb 2021 18:47:28 -0600 Subject: [PATCH 47/68] Add support for real to long long conversions. --- Gen.pas | 6 ++++-- Native.pas | 2 ++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Gen.pas b/Gen.pas index 3d53abf..4277bdd 100644 --- a/Gen.pas +++ b/Gen.pas @@ -1610,8 +1610,10 @@ else if op^.q in [longToQuad,longToUQuad] then begin GenImplied(m_pha); end; {else} end {else if} -else if op^.q in [realToQuad, realToUQuad] then - Error(cge1) {TODO: implement} +else if op^.q = realToQuad then + GenCall(89) +else if op^.q = realToUQuad then + GenCall(90) else if op^.q in [quadToWord,uquadToWord,quadToUWord,uquadToUWord] then begin GenImplied(m_pla); GenImplied(m_plx); diff --git a/Native.pas b/Native.pas index 67a77d7..1aef324 100644 --- a/Native.pas +++ b/Native.pas @@ -2043,6 +2043,8 @@ case callNum of 86: sp := @'~ASHR8'; 87: sp := @'~LSHR8'; 88: sp := @'~SCMP8'; + 89: sp := @'~CNVREALLONGLONG'; + 90: sp := @'~CNVREALULONGLONG'; otherwise: Error(cge1); end; {case} From 955ee74b2559e7cc55af82adcf6f9346c6b58117 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Tue, 16 Feb 2021 23:11:41 -0600 Subject: [PATCH 48/68] Evaluate 64-bit comparisons in constant expressions. --- Expression.asm | 300 +++++++++++++++++++++++++++++++++++++++++++++++++ Expression.pas | 56 +++++++-- 2 files changed, 346 insertions(+), 10 deletions(-) diff --git a/Expression.asm b/Expression.asm index db8fd2b..e85b36c 100644 --- a/Expression.asm +++ b/Expression.asm @@ -638,3 +638,303 @@ lshr64 start exp return end + +**************************************************************** +* +* function ult64(a,b: longlong): integer; +* +**************************************************************** +* +ult64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bge lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function uge64(a,b: longlong): integer; +* +**************************************************************** +* +uge64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 blt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function ule64(a,b: longlong): integer; +* +**************************************************************** +* +ule64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bgt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function ugt64(a,b: longlong): integer; +* +**************************************************************** +* +ugt64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 ble lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function slt64(a,b: longlong): integer; +* +**************************************************************** +* +slt64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bge lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function sge64(a,b: longlong): integer; +* +**************************************************************** +* +sge64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 blt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function sle64(a,b: longlong): integer; +* +**************************************************************** +* +sle64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bgt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function sgt64(a,b: longlong): integer; +* +**************************************************************** +* +sgt64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 ble lb2 + inc result + +lb2 return 2:result + end diff --git a/Expression.pas b/Expression.pas index a0cd7fa..6eefc63 100644 --- a/Expression.pas +++ b/Expression.pas @@ -292,6 +292,22 @@ procedure ashr64 (var x: longlong; y: integer); extern; procedure lshr64 (var x: longlong; y: integer); extern; +function ult64(a,b: longlong): integer; extern; + +function uge64(a,b: longlong): integer; extern; + +function ule64(a,b: longlong): integer; extern; + +function ugt64(a,b: longlong): integer; extern; + +function slt64(a,b: longlong): integer; extern; + +function sge64(a,b: longlong): integer; extern; + +function sle64(a,b: longlong): integer; extern; + +function sgt64(a,b: longlong): integer; extern; + {---------------------------------------------------------------} function Unary(tp: baseTypeEnum): baseTypeEnum; @@ -1313,17 +1329,37 @@ var (llop1.hi <> llop2.hi)); ekind := intconst; end; - ltch, {<} - gtch, {>} - lteqop, {<=} + ltch : begin {<} + if unsigned then + llop1.lo := ult64(llop1, llop2) + else + llop1.lo := slt64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; + gtch : begin {>} + if unsigned then + llop1.lo := ugt64(llop1, llop2) + else + llop1.lo := sgt64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; + lteqop : begin {<=} + if unsigned then + llop1.lo := ule64(llop1, llop2) + else + llop1.lo := sle64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; gteqop : begin {>=} - if kind in [normalExpression,autoInitializerExpression] - then goto 1; - Error(157); - llop1 := longlong0; - op1 := 0; - if op^.token.kind in [ltch,gtch,lteqop,gteqop] then - ekind := intconst; + if unsigned then + llop1.lo := uge64(llop1, llop2) + else + llop1.lo := sge64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; end; ltltop : begin {<<} shl64(llop1, long(llop2.lo).lsw); From b4604e079ec2102b6eee1e4c0401b06b534e6c93 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Tue, 16 Feb 2021 23:45:59 -0600 Subject: [PATCH 49/68] Do preprocessor arithmetic in intmax_t/uintmax_t (aka long long types). This is what C99 and later require. --- Expression.pas | 32 +++++++++++++++----------------- Scanner.pas | 20 +++++++++++++++++--- 2 files changed, 32 insertions(+), 20 deletions(-) diff --git a/Expression.pas b/Expression.pas index 6eefc63..9990f37 100644 --- a/Expression.pas +++ b/Expression.pas @@ -929,7 +929,7 @@ var { do an operation } - label 1; + label 1,2; var baseType: baseTypeEnum; {base type of value to cast} @@ -1047,10 +1047,10 @@ var { adjust kind of token for use in preprocessor expression } begin {PPKind} - if token.kind = intconst then - PPKind := longconst - else if token.kind = uintconst then - PPKind := ulongconst + if token.kind in [intconst,longconst] then + PPKind := longlongconst + else if token.kind in [uintconst,ulongconst] then + PPKind := ulonglongconst else PPKind := token.kind; end; {PPKind} @@ -1133,10 +1133,8 @@ var kindLeft := op^.left^.token.kind; if kindRight in [intconst,uintconst,longconst,ulongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst] then begin - if kind = preprocessorExpression then begin - kindLeft := PPKind(op^.left^.token); - kindRight := PPKind(op^.right^.token); - end; {if} + if kind = preprocessorExpression then + goto 2; {do the usual binary conversions} if (kindRight = ulongconst) or (kindLeft = ulongconst) then @@ -1269,7 +1267,7 @@ var goto 1; end; {if} end; {if} - +2: if kindRight in [intconst,uintconst,longconst,ulongconst, longlongconst,ulonglongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst, @@ -1610,13 +1608,11 @@ var else if not (op^.token.kind in [typedef,plusplusop,minusminusop,opplusplus,opminusminus,uand]) then begin - if (op^.left^.token.kind + if (kind <> preprocessorExpression) and (op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst]) then begin {evaluate a constant operation} ekind := op^.left^.token.kind; - if kind = preprocessorExpression then - ekind := PPKind(op^.left^.token); op1 := IntVal(op^.left^.token); dispose(op^.left); op^.left := nil; @@ -1640,12 +1636,14 @@ var op^.token.ival := long(op1).lsw; end; {else} end {if} - else if op^.left^.token.kind - in [longlongconst,ulonglongconst] then begin + else if op^.left^.token.kind in [longlongconst,ulonglongconst, + intconst,uintconst,longconst,ulongconst] then begin - {evaluate a constant operation} + {evaluate a constant operation with long long operand} ekind := op^.left^.token.kind; - llop1 := op^.left^.token.qval; + if kind = preprocessorExpression then + ekind := PPKind(op^.left^.token); + GetLongLongVal(llop1, op^.left^.token); dispose(op^.left); op^.left := nil; case op^.token.kind of diff --git a/Scanner.pas b/Scanner.pas index 8b3ebdb..f4ba67e 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -2845,6 +2845,9 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin { 16 - check for stack errors } FlagPragmas(p_debug); NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; val := long(expressionValue).lsw; rangeCheck := odd(val); debugFlag := odd(val >> 1); @@ -2859,7 +2862,10 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin end {else} else if token.name^ = 'lint' then begin FlagPragmas(p_lint); - NumericDirective; + NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; lint := long(expressionValue).lsw; lintIsError := true; if token.kind = semicolonch then begin @@ -2893,7 +2899,10 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin { 16 - common subexpression elimination } { 32 - loop invariant removal } FlagPragmas(p_optimize); - NumericDirective; + NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; val := long(expressionValue).lsw; peepHole := odd(val); npeepHole := odd(val >> 1); @@ -2990,7 +2999,10 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin { 8 - allow // comments } { 16 - allow mixed decls & use C99 scope rules } FlagPragmas(p_ignore); - NumericDirective; + NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; val := long(expressionValue).lsw; skipIllegalTokens := odd(val); allowLongIntChar := odd(val >> 1); @@ -3342,6 +3354,8 @@ if c2 in ['f','F'] then begin {allow F designator on reals} NextChar; end; {if} numString[0] := chr(stringIndex); {set the length of the string} +if doingPPExpression then + isLongLong := true; if isReal then begin {convert a real constant} token.kind := doubleConst; token.class := doubleConstant; From 6bb91d20e5cbef042907adaaedb9af0c05debd97 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Wed, 17 Feb 2021 14:41:09 -0600 Subject: [PATCH 50/68] Add the predefined macro __ORCAC_HAS_LONG_LONG__. This allows headers or other code to test for the presence of this feature. --- Scanner.pas | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/Scanner.pas b/Scanner.pas index f4ba67e..a727a1b 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -1491,7 +1491,7 @@ if macro^.readOnly then begin {handle special macros} 5: begin {__STDC__} token.kind := intConst; {__ORCAC__} token.numString := @oneStr; {__STDC_NO_...__} - token.class := intConstant; + token.class := intConstant; {__ORCAC_HAS_LONG_LONG__} token.ival := 1; oneStr := '1'; tokenStart := @oneStr[1]; @@ -3863,6 +3863,15 @@ mp^.algorithm := 6; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; +new(mp); {__ORCAC_HAS_LONG_LONG__} +mp^.name := @'__ORCAC_HAS_LONG_LONG__'; +mp^.parameters := -1; +mp^.tokens := nil; +mp^.readOnly := true; +mp^.algorithm := 5; +bp := pointer(ord4(macros) + hash(mp^.name)); +mp^.next := bp^; +bp^ := mp; new(mp); {__STDC_NO_ATOMICS__} mp^.name := @'__STDC_NO_ATOMICS__'; mp^.parameters := -1; From 31adb5f5d68d97c4d0c5b15fd0573faf445e59d9 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Wed, 17 Feb 2021 14:57:18 -0600 Subject: [PATCH 51/68] Update headers to support long long (and intmax_t typedef'd as long long). This includes: *Functions operating on long long in *Limits of long long types in *64-bit types and limits (plus intmax_t and its limits) in *New format codes, plus functions operating on intmax_t, in The new stuff is generally conditionalized to only be included if __ORCAC_HAS_LONG_LONG__ is defined, or if the implementation claims to be C99 or later. This allows the headers to remain usable with older versions of ORCA/C, or with any hypothetical "strict C89" mode that might be implemented in the future. --- ORCACDefs/inttypes.h | 89 ++++++++++++++++++++++++++++---------------- ORCACDefs/limits.h | 5 +++ ORCACDefs/stdint.h | 84 +++++++++++++++++++++++++++++++---------- ORCACDefs/stdlib.h | 14 +++++++ 4 files changed, 140 insertions(+), 52 deletions(-) diff --git a/ORCACDefs/inttypes.h b/ORCACDefs/inttypes.h index d4ed0a1..8d3dbba 100644 --- a/ORCACDefs/inttypes.h +++ b/ORCACDefs/inttypes.h @@ -7,15 +7,6 @@ * ****************************************************************/ -/* - * Note: The format specifier macros defined here generally comply with the - * C99 and C11 standards, except that those associated with intmax_t and - * uintmax_t correspond to their non-standard definitions as 32-bit types. - * - * The functions that the standards specify should be declared in this header - * are not available. - */ - #ifndef __inttypes__ #define __inttypes__ @@ -26,25 +17,31 @@ #define PRId8 "d" /* int8_t */ #define PRId16 "d" /* int16_t */ #define PRId32 "ld" /* int32_t */ +#define PRId64 "lld" /* int64_t */ #define PRIdLEAST8 "d" /* int_least8_t */ #define PRIdLEAST16 "d" /* int_least16_t */ #define PRIdLEAST32 "ld" /* int_least32_t */ +#define PRIdLEAST64 "lld" /* int_least64_t */ #define PRIdFAST8 "d" /* int_fast8_t */ #define PRIdFAST16 "d" /* int_fast16_t */ #define PRIdFAST32 "ld" /* int_fast32_t */ -#define PRIdMAX "ld" /* intmax_t */ +#define PRIdFAST64 "lld" /* int_fast64_t */ +#define PRIdMAX "jd" /* intmax_t */ #define PRIdPTR "ld" /* intptr_t */ #define PRIi8 "i" /* int8_t */ #define PRIi16 "i" /* int16_t */ #define PRIi32 "li" /* int32_t */ +#define PRIi64 "lli" /* int64_t */ #define PRIiLEAST8 "i" /* int_least8_t */ #define PRIiLEAST16 "i" /* int_least16_t */ #define PRIiLEAST32 "li" /* int_least32_t */ +#define PRIiLEAST64 "lli" /* int_least64_t */ #define PRIiFAST8 "i" /* int_fast8_t */ #define PRIiFAST16 "i" /* int_fast16_t */ #define PRIiFAST32 "li" /* int_fast32_t */ -#define PRIiMAX "li" /* intmax_t */ +#define PRIiFAST64 "lli" /* int_fast64_t */ +#define PRIiMAX "ji" /* intmax_t */ #define PRIiPTR "li" /* intptr_t */ /* fprintf macros for unsigned integers */ @@ -52,49 +49,61 @@ #define PRIo8 "o" /* uint8_t */ #define PRIo16 "o" /* uint16_t */ #define PRIo32 "lo" /* uint32_t */ +#define PRIo64 "llo" /* uint64_t */ #define PRIoLEAST8 "o" /* uint_least8_t */ #define PRIoLEAST16 "o" /* uint_least16_t */ #define PRIoLEAST32 "lo" /* uint_least32_t */ +#define PRIoLEAST64 "llo" /* uint_least64_t */ #define PRIoFAST8 "o" /* uint_fast8_t */ #define PRIoFAST16 "o" /* uint_fast16_t */ #define PRIoFAST32 "lo" /* uint_fast32_t */ -#define PRIoMAX "lo" /* uintmax_t */ +#define PRIoFAST64 "llo" /* uint_fast64_t */ +#define PRIoMAX "jo" /* uintmax_t */ #define PRIoPTR "lo" /* uintptr_t */ #define PRIu8 "u" /* uint8_t */ #define PRIu16 "u" /* uint16_t */ #define PRIu32 "lu" /* uint32_t */ +#define PRIu64 "llu" /* uint64_t */ #define PRIuLEAST8 "u" /* uint_least8_t */ #define PRIuLEAST16 "u" /* uint_least16_t */ #define PRIuLEAST32 "lu" /* uint_least32_t */ +#define PRIuLEAST64 "llu" /* uint_least64_t */ #define PRIuFAST8 "u" /* uint_fast8_t */ #define PRIuFAST16 "u" /* uint_fast16_t */ #define PRIuFAST32 "lu" /* uint_fast32_t */ -#define PRIuMAX "lu" /* uintmax_t */ +#define PRIuFAST64 "llu" /* uint_fast64_t */ +#define PRIuMAX "ju" /* uintmax_t */ #define PRIuPTR "lu" /* uintptr_t */ #define PRIx8 "x" /* uint8_t */ #define PRIx16 "x" /* uint16_t */ #define PRIx32 "lx" /* uint32_t */ +#define PRIx64 "llx" /* uint64_t */ #define PRIxLEAST8 "x" /* uint_least8_t */ #define PRIxLEAST16 "x" /* uint_least16_t */ #define PRIxLEAST32 "lx" /* uint_least32_t */ +#define PRIxLEAST64 "llx" /* uint_least64_t */ #define PRIxFAST8 "x" /* uint_fast8_t */ #define PRIxFAST16 "x" /* uint_fast16_t */ #define PRIxFAST32 "lx" /* uint_fast32_t */ -#define PRIxMAX "lx" /* uintmax_t */ +#define PRIxFAST64 "llx" /* uint_fast64_t */ +#define PRIxMAX "jx" /* uintmax_t */ #define PRIxPTR "lx" /* uintptr_t */ #define PRIX8 "X" /* uint8_t */ #define PRIX16 "X" /* uint16_t */ #define PRIX32 "lX" /* uint32_t */ +#define PRIX64 "llX" /* uint64_t */ #define PRIXLEAST8 "X" /* uint_least8_t */ #define PRIXLEAST16 "X" /* uint_least16_t */ #define PRIXLEAST32 "lX" /* uint_least32_t */ +#define PRIXLEAST64 "llX" /* uint_least64_t */ #define PRIXFAST8 "X" /* uint_fast8_t */ #define PRIXFAST16 "X" /* uint_fast16_t */ #define PRIXFAST32 "lX" /* uint_fast32_t */ -#define PRIXMAX "lX" /* uintmax_t */ +#define PRIXFAST64 "llX" /* uint_fast64_t */ +#define PRIXMAX "jX" /* uintmax_t */ #define PRIXPTR "lX" /* uintptr_t */ /* fscanf macros for signed integers */ @@ -102,25 +111,31 @@ #define SCNd8 "hhd" /* int8_t */ #define SCNd16 "hd" /* int16_t */ #define SCNd32 "ld" /* int32_t */ +#define SCNd64 "lld" /* int64_t */ #define SCNdLEAST8 "hhd" /* int_least8_t */ #define SCNdLEAST16 "hd" /* int_least16_t */ #define SCNdLEAST32 "ld" /* int_least32_t */ +#define SCNdLEAST64 "lld" /* int_least64_t */ #define SCNdFAST8 "hd" /* int_fast8_t */ #define SCNdFAST16 "hd" /* int_fast16_t */ #define SCNdFAST32 "ld" /* int_fast32_t */ -#define SCNdMAX "ld" /* intmax_t */ +#define SCNdFAST64 "lld" /* int_fast64_t */ +#define SCNdMAX "jd" /* intmax_t */ #define SCNdPTR "ld" /* intptr_t */ #define SCNi8 "hhi" /* int8_t */ #define SCNi16 "hi" /* int16_t */ #define SCNi32 "li" /* int32_t */ +#define SCNi64 "lli" /* int64_t */ #define SCNiLEAST8 "hhi" /* int_least8_t */ #define SCNiLEAST16 "hi" /* int_least16_t */ #define SCNiLEAST32 "li" /* int_least32_t */ +#define SCNiLEAST64 "lli" /* int_least64_t */ #define SCNiFAST8 "hi" /* int_fast8_t */ #define SCNiFAST16 "hi" /* int_fast16_t */ #define SCNiFAST32 "li" /* int_fast32_t */ -#define SCNiMAX "li" /* intmax_t */ +#define SCNiFAST64 "lli" /* int_fast64_t */ +#define SCNiMAX "ji" /* intmax_t */ #define SCNiPTR "li" /* intptr_t */ /* fscanf macros for unsigned integers */ @@ -128,53 +143,63 @@ #define SCNo8 "hho" /* uint8_t */ #define SCNo16 "ho" /* uint16_t */ #define SCNo32 "lo" /* uint32_t */ +#define SCNo64 "llo" /* uint64_t */ #define SCNoLEAST8 "hho" /* uint_least8_t */ #define SCNoLEAST16 "ho" /* uint_least16_t */ #define SCNoLEAST32 "lo" /* uint_least32_t */ +#define SCNoLEAST64 "llo" /* uint_least64_t */ #define SCNoFAST8 "ho" /* uint_fast8_t */ #define SCNoFAST16 "ho" /* uint_fast16_t */ #define SCNoFAST32 "lo" /* uint_fast32_t */ -#define SCNoMAX "lo" /* uintmax_t */ +#define SCNoFAST64 "llo" /* uint_fast64_t */ +#define SCNoMAX "jo" /* uintmax_t */ #define SCNoPTR "lo" /* uintptr_t */ #define SCNu8 "hhu" /* uint8_t */ #define SCNu16 "hu" /* uint16_t */ #define SCNu32 "lu" /* uint32_t */ +#define SCNu64 "llu" /* uint64_t */ #define SCNuLEAST8 "hhu" /* uint_least8_t */ #define SCNuLEAST16 "hu" /* uint_least16_t */ #define SCNuLEAST32 "lu" /* uint_least32_t */ +#define SCNuLEAST64 "llu" /* uint_least64_t */ #define SCNuFAST8 "hu" /* uint_fast8_t */ #define SCNuFAST16 "hu" /* uint_fast16_t */ #define SCNuFAST32 "lu" /* uint_fast32_t */ -#define SCNuMAX "lu" /* uintmax_t */ +#define SCNuFAST64 "llu" /* uint_fast64_t */ +#define SCNuMAX "ju" /* uintmax_t */ #define SCNuPTR "lu" /* uintptr_t */ #define SCNx8 "hhx" /* uint8_t */ #define SCNx16 "hx" /* uint16_t */ #define SCNx32 "lx" /* uint32_t */ +#define SCNx64 "llx" /* uint64_t */ #define SCNxLEAST8 "hhx" /* uint_least8_t */ #define SCNxLEAST16 "hx" /* uint_least16_t */ #define SCNxLEAST32 "lx" /* uint_least32_t */ +#define SCNxLEAST64 "llx" /* uint_least64_t */ #define SCNxFAST8 "hx" /* uint_fast8_t */ #define SCNxFAST16 "hx" /* uint_fast16_t */ #define SCNxFAST32 "lx" /* uint_fast32_t */ -#define SCNxMAX "lx" /* uintmax_t */ +#define SCNxFAST64 "llx" /* uint_fast64_t */ +#define SCNxMAX "jx" /* uintmax_t */ #define SCNxPTR "lx" /* uintptr_t */ +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef struct {intmax_t quot,rem;} imaxdiv_t; + +intmax_t imaxabs(intmax_t); +imaxdiv_t imaxdiv(intmax_t, intmax_t); +intmax_t strtoimax(const char * restrict, char ** restrict, int); +uintmax_t strtoumax(const char * restrict, char ** restrict, int); +#endif + /* - * The C99 and C11 standards require the following functions and the - * type imaxdiv_t to be declared here, but they are not currently supported. + * The C99 and C11 standards require the following functions + * to be declared here, but they are not currently supported. * - * intmax_t imaxabs(intmax_t j); - * imaxdiv_t imaxdiv(intmax_t numer, intmax_t denom); - * intmax_t strtoimax(const char * restrict nptr, - * char ** restrict endptr, int base); - * uintmax_t strtoumax(const char * restrict nptr, - * char ** restrict endptr, int base); - * intmax_t wcstoimax(const wchar_t * restrict nptr, - * wchar_t ** restrict endptr, int base); - * uintmax_t wcstoumax(const wchar_t * restrict nptr, - * wchar_t ** restrict endptr, int base); + * intmax_t wcstoimax(const wchar_t * restrict, wchar_t ** restrict, int); + * uintmax_t wcstoumax(const wchar_t * restrict, wchar_t ** restrict, int); */ #endif diff --git a/ORCACDefs/limits.h b/ORCACDefs/limits.h index 06e2c0d..213b212 100644 --- a/ORCACDefs/limits.h +++ b/ORCACDefs/limits.h @@ -29,5 +29,10 @@ #define UINT_MAX 65535u #define ULONG_MAX 4294967295u #define USHRT_MAX 65535u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define LLONG_MIN (-9223372036854775807-1) +#define LLONG_MAX 9223372036854775807 +#define ULLONG_MAX 18446744073709551615u +#endif #endif diff --git a/ORCACDefs/stdint.h b/ORCACDefs/stdint.h index 6b54104..a425c50 100644 --- a/ORCACDefs/stdint.h +++ b/ORCACDefs/stdint.h @@ -7,12 +7,6 @@ * ****************************************************************/ -/* - * Note: This header mostly complies with the C99 and C11 standards, - * except that 64-bit types are not provided because ORCA/C does not - * support them. See comments below for further details. - */ - #ifndef __stdint__ #define __stdint__ @@ -20,80 +14,122 @@ typedef signed char int8_t; typedef short int16_t; typedef long int32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long int64_t; +#endif typedef unsigned char uint8_t; typedef unsigned short uint16_t; typedef unsigned long uint32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef unsigned long long uint64_t; +#endif /* Minimum-width integer types */ typedef signed char int_least8_t; typedef short int_least16_t; typedef long int_least32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long int_least64_t; +#endif typedef unsigned char uint_least8_t; typedef unsigned short uint_least16_t; typedef unsigned long uint_least32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef unsigned long long uint_least64_t; +#endif /* Fastest minimum-width integer types */ typedef short int_fast8_t; /* Note: 16-bit type */ typedef short int_fast16_t; typedef long int_fast32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long int_fast64_t; +#endif typedef unsigned short uint_fast8_t; /* Note: 16-bit type */ typedef unsigned short uint_fast16_t; typedef unsigned long uint_fast32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef unsigned long long uint_fast64_t; +#endif /* Integer types capable of holding object pointers */ typedef long intptr_t; typedef unsigned long uintptr_t; /* Greatest-width integer types */ -/* - * Note: In C99 and C11, these are required to be at least 64 bits. - * Since ORCA/C does not currently support 64-bit integer types, - * they are currently defined as 32-bit types instead. - */ -typedef long intmax_t; -typedef unsigned long uintmax_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long intmax_t; +typedef unsigned long long uintmax_t; +#endif /* Limits of exact-width integer types */ #define INT8_MIN (-128) #define INT16_MIN (-32767-1) #define INT32_MIN (-2147483647-1) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT64_MIN (-9223372036854775807-1) +#endif #define INT8_MAX 127 #define INT16_MAX 32767 #define INT32_MAX 2147483647 +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT64_MAX 9223372036854775807 +#endif #define UINT8_MAX 255 #define UINT16_MAX 65535u #define UINT32_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT64_MAX 18446744073709551615u +#endif /* Limits of minimum-width integer types */ #define INT_LEAST8_MIN (-128) #define INT_LEAST16_MIN (-32767-1) #define INT_LEAST32_MIN (-2147483647-1) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_LEAST64_MIN (-9223372036854775807-1) +#endif #define INT_LEAST8_MAX 127 #define INT_LEAST16_MAX 32767 #define INT_LEAST32_MAX 2147483647 +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_LEAST64_MAX 9223372036854775807 +#endif #define UINT_LEAST8_MAX 255 #define UINT_LEAST16_MAX 65535u #define UINT_LEAST32_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT_LEAST64_MAX 18446744073709551615u +#endif /* Limits of fastest minimum-width integer types */ #define INT_FAST8_MIN (-32767-1) #define INT_FAST16_MIN (-32767-1) #define INT_FAST32_MIN (-2147483647-1) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_FAST64_MIN (-9223372036854775807-1) +#endif #define INT_FAST8_MAX 32767 #define INT_FAST16_MAX 32767 #define INT_FAST32_MAX 2147483647 +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_FAST64_MAX 9223372036854775807 +#endif #define UINT_FAST8_MAX 65535u #define UINT_FAST16_MAX 65535u #define UINT_FAST32_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT_FAST64_MAX 18446744073709551615u +#endif /* Limits of integer types capable of holding object pointers */ #define INTPTR_MIN (-2147483647-1) @@ -101,10 +137,11 @@ typedef unsigned long uintmax_t; #define UINTPTR_MAX 4294967295u /* Limits of greatest-width integer types */ -/* Note: These limits are smaller than C99 and C11 require. */ -#define INTMAX_MIN (-2147483647-1) -#define INTMAX_MAX 2147483647 -#define UINTMAX_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INTMAX_MIN (-9223372036854775807-1) +#define INTMAX_MAX 9223372036854775807 +#define UINTMAX_MAX 18446744073709551615u +#endif /* Limits of other integer types */ #define PTRDIFF_MIN (-2147483647-1) @@ -128,14 +165,21 @@ typedef unsigned long uintmax_t; #define INT8_C(val) (val) #define INT16_C(val) (val) #define INT32_C(val) (val ## L) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT64_C(val) (val ## LL) +#endif #define UINT8_C(val) (val) #define UINT16_C(val) (val ## U) #define UINT32_C(val) (val ## UL) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT64_C(val) (val ## ULL) +#endif /* Macros for greatest-width integer constants */ -/* Note: These use 32-bit types, consistent with intmax_t and uintmax_t. */ -#define INTMAX_C(val) (val ## L) -#define UINTMAX_C(val) (val ## UL) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INTMAX_C(val) (val ## LL) +#define UINTMAX_C(val) (val ## ULL) +#endif #endif diff --git a/ORCACDefs/stdlib.h b/ORCACDefs/stdlib.h index 8561a70..2e29570 100644 --- a/ORCACDefs/stdlib.h +++ b/ORCACDefs/stdlib.h @@ -29,6 +29,9 @@ typedef unsigned long size_t; typedef struct {int quot,rem;} div_t; typedef struct {long quot,rem;} ldiv_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef struct {long long quot,rem;} lldiv_t; +#endif #ifndef __KeepNamespacePure__ #define clalloc(x,y) calloc((x),(y)) @@ -45,6 +48,9 @@ int at_quick_exit(void (*__func)(void)); double atof(const char *); int atoi(const char *); long atol(const char *); +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +long long atoll(const char *); +#endif void *bsearch(const void *, const void *, size_t, size_t, int (*__compar)(const void *, const void *)); void *calloc(size_t, size_t); div_t div(int, int); @@ -55,6 +61,10 @@ void free(void *); char *getenv(const char *); long labs(long); ldiv_t ldiv(long, long); +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +long long llabs(long long); +lldiv_t lldiv(long long, long long); +#endif void *malloc(size_t); void qsort(void *, size_t, size_t, int (*__compar)(const void *, const void *)); void quick_exit(int); @@ -64,6 +74,10 @@ void srand(unsigned); double strtod(const char *, char **); long strtol(const char *, char **, int); unsigned long strtoul(const char *, char **, int); +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +long long strtoll(const char * restrict, char ** restrict, int); +unsigned long long strtoull(const char * restrict, char ** restrict, int); +#endif int system(const char *); #endif From cf463ff155b044c7cd66d4373f168e5cff311a8f Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Wed, 17 Feb 2021 19:41:46 -0600 Subject: [PATCH 52/68] Support switch statements using long long expressions. --- CCommon.pas | 1 + Expression.pas | 27 +++++++++++++++++ Parser.pas | 79 +++++++++++++++++++++++++++++++++----------------- 3 files changed, 80 insertions(+), 27 deletions(-) diff --git a/CCommon.pas b/CCommon.pas index 0c060da..e587ccd 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -496,6 +496,7 @@ var expressionType: typePtr; {the type of the expression} initializerTree: tokenPtr; {for non-constant initializers} isConstant: boolean; {is the initializer expression constant?} + expressionIsLongLong: boolean; {is the last constant expression long long?} {type specifier results} {----------------------} diff --git a/Expression.pas b/Expression.pas index 9990f37..97463e3 100644 --- a/Expression.pas +++ b/Expression.pas @@ -216,6 +216,11 @@ function UsualUnaryConversions: baseTypeEnum; { outputs: } { expressionType - set to result type } +procedure GetLLExpressionValue (var val: longlong); + +{ get the value of the last integer constant expression as a } +{ long long (whether it had long long type or not). } + {---------------------------------------------------------------} implementation @@ -4264,6 +4269,7 @@ else begin {record the expression for an initialize isConstant := false; llExpressionValue.lo := 0; llExpressionValue.hi := 0; + expressionIsLongLong := false; if errorFound then begin DisposeTree(initializerTree); initializerTree := nil; @@ -4321,6 +4327,7 @@ else begin {record the expression for an initialize end {else if} else if tree^.token.kind = longlongconst then begin llExpressionValue := tree^.token.qval; + expressionIsLongLong := true; if ((llExpressionValue.hi = 0) and (llExpressionValue.lo >= 0)) or ((llExpressionValue.hi = -1) and (llExpressionValue.lo < 0)) then expressionValue := llExpressionValue.lo @@ -4333,6 +4340,7 @@ else begin {record the expression for an initialize end {else if} else if tree^.token.kind = ulonglongconst then begin llExpressionValue := tree^.token.qval; + expressionIsLongLong := true; if llExpressionValue.hi = 0 then expressionValue := llExpressionValue.lo else @@ -4370,6 +4378,25 @@ else begin {record the expression for an initialize end; {Expression} +procedure GetLLExpressionValue {var val: longlong}; + +{ get the value of the last integer constant expression as a } +{ long long (whether it had long long type or not). } + +begin {GetLLExpressionValue} + if expressionIsLongLong then + val := llExpressionValue + else begin + val.lo := expressionValue; + val.hi := 0; + if expressionValue < 0 then + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgByte,cgWord,cgLong] then + val.hi := -1; + end; +end; {GetLLExpressionValue} + + procedure InitExpression; { initialize the expression handler } diff --git a/Parser.pas b/Parser.pas index 13f194a..d8d8813 100644 --- a/Parser.pas +++ b/Parser.pas @@ -98,7 +98,7 @@ type switchRecord = record next,last: switchPtr; {doubly linked list (for inserts)} lab: integer; {label to branch to} - val: longint; {switch value} + val: longlong; {switch value} end; {token stack} @@ -139,7 +139,6 @@ type ); switchSt: ( maxVal: longint; {max switch value} - isLong: boolean; {do long switch?} ln: integer; {temp var number} size: integer; {temp var size} labelCount: integer; {# of switch labels} @@ -188,6 +187,12 @@ var declarationSpecifiersElement: tokenSet; structDeclarationStart: tokenSet; +{-- External procedures ----------------------------------------} + +function slt64(a,b: longlong): boolean; extern; + +function sgt64(a,b: longlong): boolean; extern; + {-- Parser Utility Procedures ----------------------------------} procedure Match {kind: tokenEnum; err: integer}; @@ -454,38 +459,52 @@ var var stPtr: statementPtr; {switch record for this case label} swPtr,swPtr2: switchPtr; {work pointers for inserting new entry} - val: integer; {case label value} + val: longlong; {case label value} begin {CaseStatement} while token.kind = casesy do begin NextToken; {skip the 'case' token} stPtr := GetSwitchRecord; {get the proper switch record} Expression(arrayExpression, [colonch]); {evaluate the branch condition} - val := long(expressionValue).lsw; - if val <> expressionValue then - if not stPtr^.isLong then - expressionValue := val; {convert out-of-range value to (U)Word} + GetLLExpressionValue(val); + if stPtr^.size = cgLongSize then begin {convert out-of-range values} + if val.lo < 0 then + val.hi := -1 + else + val.hi := 0; + end {if} + else if stPtr^.size = cgWordSize then begin + if long(val.lo).lsw < 0 then begin + val.hi := -1; + val.lo := val.lo | $FFFF0000; + end {if} + else begin + val.hi := 0; + val.lo := val.lo & $0000FFFF; + end; {else} + end; {else if} if stPtr = nil then Error(72) else begin new(swPtr2); {create the new label table entry} swPtr2^.lab := GenLabel; Gen1(dc_lab, swPtr2^.lab); - swPtr2^.val := expressionValue; + swPtr2^.val := val; swPtr := stPtr^.switchList; + if val.lo > stPtr^.maxVal then + stPtr^.maxVal := val.lo; if swPtr = nil then begin {enter it in the table} swPtr2^.last := nil; swPtr2^.next := nil; stPtr^.switchList := swPtr2; - stPtr^.maxVal := expressionValue; stPtr^.labelCount := 1; end {if} else begin - while (swPtr^.next <> nil) and (swPtr^.val < expressionValue) do + while (swPtr^.next <> nil) and slt64(swPtr^.val, val) do swPtr := swPtr^.next; - if swPtr^.val = expressionValue then + if (swPtr^.val.lo = val.lo) and (swPtr^.val.hi = val.hi) then Error(73) - else if swPtr^.val > expressionValue then begin + else if sgt64(swPtr^.val, val) then begin swPtr2^.next := swPtr; if swPtr^.last = nil then stPtr^.switchList := swPtr2 @@ -498,7 +517,6 @@ var swPtr2^.next := nil; swPtr2^.last := swPtr; swPtr^.next := swPtr2; - stPtr^.maxVal := expressionValue; end; {else} stPtr^.labelCount := stPtr^.labelCount + 1; end; {else} @@ -798,7 +816,6 @@ var statementList := stPtr; stPtr^.kind := switchSt; stPtr^.maxVal := -maxint4; - stPtr^.isLong := false; stPtr^.labelCount := 0; stPtr^.switchLab := GenLabel; stPtr^.switchExit := GenLabel; @@ -815,14 +832,17 @@ var case tp^.kind of scalarType: - if tp^.baseType in [cgLong,cgULong] then begin - stPtr^.isLong := true; + if tp^.baseType in [cgQuad,cgUQuad] then begin + stPtr^.size := cgQuadSize; + stPtr^.ln := GetTemp(cgQuadSize); + Gen2t(pc_str, stPtr^.ln, 0, cgQuad); + end {if} + else if tp^.baseType in [cgLong,cgULong] then begin stPtr^.size := cgLongSize; stPtr^.ln := GetTemp(cgLongSize); Gen2t(pc_str, stPtr^.ln, 0, cgLong); end {if} else if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin - stPtr^.isLong := false; stPtr^.size := cgWordSize; stPtr^.ln := GetTemp(cgWordSize); Gen2t(pc_str, stPtr^.ln, 0, cgWord); @@ -831,7 +851,6 @@ var Error(71); enumType: begin - stPtr^.isLong := false; stPtr^.size := cgWordSize; stPtr^.ln := GetTemp(cgWordSize); Gen2t(pc_str, stPtr^.ln, 0, cgWord); @@ -1075,13 +1094,15 @@ var {-------------------------------} exitLab: integer; {label at the end of the jump table} isLong: boolean; {is the case expression long?} + isLongLong: boolean; {is the case expression long long?} swPtr,swPtr2: switchPtr; {switch label table list} begin {EndSwitchStatement} if c99Scope then PopTable; stPtr := statementList; {get the statement record} exitLab := stPtr^.switchExit; {get the exit label} -isLong := stPtr^.isLong; {get the long flag} +isLong := stPtr^.size = cgLongSize; {get the long flag} +isLongLong := stPtr^.size = cgQuadSize; {get the long long flag} swPtr := stPtr^.switchList; {Skip further generation if there were} if swPtr <> nil then begin { no labels. } default := stPtr^.switchDefault; {get a default label} @@ -1089,21 +1110,25 @@ if swPtr <> nil then begin { no labels. } default := exitLab; Gen1(pc_ujp, exitLab); {branch past the indexed jump} Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table} - if isLong then {decide on a base type} + if isLongLong then {decide on a base type} + ltp := cgQuad + else if isLong then ltp := cgLong else ltp := cgWord; - if stPtr^.isLong - or (((stPtr^.maxVal-swPtr^.val) div stPtr^.labelCount) > sparse) then + if isLong or isLongLong + or (((stPtr^.maxVal-swPtr^.val.lo) div stPtr^.labelCount) > sparse) then begin {Long expressions and sparse switch statements are handled as a } {series of if-goto tests. } while swPtr <> nil do begin {generate the compares} - if isLong then - GenLdcLong(swPtr^.val) + if isLongLong then + GenLdcQuad(swPtr^.val) + else if isLong then + GenLdcLong(swPtr^.val.lo) else - Gen1t(pc_ldc, long(swPtr^.val).lsw, cgWord); + Gen1t(pc_ldc, long(swPtr^.val.lo).lsw, cgWord); Gen2t(pc_lod, stPtr^.ln, 0, ltp); Gen0t(pc_equ, ltp); Gen1(pc_tjp, swPtr^.lab); @@ -1116,12 +1141,12 @@ if swPtr <> nil then begin { no labels. } else begin {compact word switch statements are handled with xjp} - minVal := long(swPtr^.val).lsw; {record the min label value} + minVal := long(swPtr^.val.lo).lsw; {record the min label value} Gen2t(pc_lod, stPtr^.ln, 0, ltp); {get the value} Gen1t(pc_dec, minVal, cgWord); {adjust the range} Gen1(pc_xjp, ord(stPtr^.maxVal-minVal+1)); {do the indexed jump} while swPtr <> nil do begin {generate the jump table} - while minVal < swPtr^.val do begin + while minVal < swPtr^.val.lo do begin Gen1(pc_add, default); minVal := minVal+1; end; {while} From 32f4e70826c1f78584d07ce6a2c5df75ff90eee9 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 18 Feb 2021 12:58:57 -0600 Subject: [PATCH 53/68] Fix a comment. --- Symbol.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Symbol.pas b/Symbol.pas index 0c798e8..5316e3e 100644 --- a/Symbol.pas +++ b/Symbol.pas @@ -1324,7 +1324,7 @@ with longLongPtr^ do begin baseType := cgQuad; cType := ctLongLong; end; {with} -new(uLongLongPtr); {unsigned long} +new(uLongLongPtr); {unsigned long long} with uLongLongPtr^ do begin size := cgQuadSize; saveDisp := 0; From d891e672e3d75c0de6ecc6752360e7655897e932 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 18 Feb 2021 19:17:39 -0600 Subject: [PATCH 54/68] Add various intermediate code peephole optimizations. These mainly cover 64-bit arithmetic and shifts, but also include a few optimizations for 16-bit and 32-bit shifts. --- CGC.asm | 54 ++++++++++ CGC.macros | 173 +++++++++++++++++++++++++++++++ CGC.pas | 18 ++++ DAG.pas | 298 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 4 files changed, 526 insertions(+), 17 deletions(-) diff --git a/CGC.asm b/CGC.asm index 86bfd11..716a217 100644 --- a/CGC.asm +++ b/CGC.asm @@ -85,6 +85,60 @@ rec_cmp equ 18 disp to comp (SANE) value rtl end +**************************************************************** +* +* procedure CnvXLL (var result: longlong; val: extended); +* +* Convert floating point to long long +* +* Inputs: +* result - longlong to hold the converted value +* val - the real value +* +**************************************************************** + +CnvXLL start cg + + subroutine (4:result,10:val),0 + + pei (val+8) + pei (val+6) + pei (val+4) + pei (val+2) + pei (val) + jsl ~CnvRealLongLong + pl8 [result] + + return + end + +**************************************************************** +* +* procedure CnvXULL (var result: longlong; val: extended); +* +* Convert floating point to unsigned long long +* +* Inputs: +* result - longlong to hold the converted value +* val - the real value +* +**************************************************************** + +CnvXULL start cg + + subroutine (4:result,10:val),0 + + pei (val+8) + pei (val+6) + pei (val+4) + pei (val+2) + pei (val) + jsl ~CnvRealULongLong + pl8 [result] + + return + end + datachk off **************************************************************** * diff --git a/CGC.macros b/CGC.macros index 2a32ccc..3f9e3c4 100644 --- a/CGC.macros +++ b/CGC.macros @@ -186,3 +186,176 @@ LDX #$090A JSL $E10000 MEND + macro +&l pl8 &n1 + lclc &c +&l anop + aif s:longa=1,.a + rep #%00100000 +.a +&c amid &n1,1,1 + aif "&c"<>"{",.b +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.f +&n1 amid &n1,2,l:&n1-2 + pla + sta (&n1) + ldy #2 + pla + sta (&n1),y + ldy #4 + pla + sta (&n1),y + ldy #6 + pla + sta (&n1),y + ago .d +.b + aif "&c"<>"[",.c + pla + sta &n1 + ldy #2 + pla + sta &n1,y + ldy #4 + pla + sta &n1,y + ldy #6 + pla + sta &n1,y + ago .d +.c + pla + sta &n1 + pla + sta &n1+2 + pla + sta &n1+4 + pla + sta &n1+6 +.d + aif s:longa=1,.e + sep #%00100000 +.e + mexit +.f + mnote "Missing closing '}'",16 + mend + MACRO +&lab subroutine &parms,&work +&lab anop + aif c:&work,.a + lclc &work +&work setc 0 +.a + gbla &totallen + gbla &worklen +&worklen seta &work +&totallen seta 0 + aif c:&parms=0,.e + lclc &len + lclc &p + lcla &i +&i seta c:&parms +.b +&p setc &parms(&i) +&len amid &p,2,1 + aif "&len"=":",.c +&len amid &p,1,2 +&p amid &p,4,l:&p-3 + ago .d +.c +&len amid &p,1,1 +&p amid &p,3,l:&p-2 +.d +&p equ &totallen+3+&work +&totallen seta &totallen+&len +&i seta &i-1 + aif &i,^b +.e + tsc + sec + sbc #&work + tcs + inc a + phd + tcd + mend + MACRO +&lab return &r +&lab anop + lclc &len + aif c:&r,.a + lclc &r +&r setc 0 +&len setc 0 + ago .h +.a +&len amid &r,2,1 + aif "&len"=":",.b +&len amid &r,1,2 +&r amid &r,4,l:&r-3 + ago .c +.b +&len amid &r,1,1 +&r amid &r,3,l:&r-2 +.c + aif &len<>2,.d + ldy &r + ago .h +.d + aif &len<>4,.e + ldx &r+2 + ldy &r + ago .h +.e + aif &len<>10,.g + aif &totallen=0,.f + lda &worklen+1 + sta &worklen+&totallen+1 + lda &worklen + sta &worklen+&totallen +.f + pld + tsc + clc + adc #&worklen+&totallen + tcs + phb + plx + ply + lda &r+8 + pha + lda &r+6 + pha + lda &r+4 + pha + lda &r+2 + pha + lda &r + pha + phy + phx + plb + rtl + mexit +.g + mnote 'Not a valid return length',16 + mexit +.h + aif &totallen=0,.i + lda &worklen+1 + sta &worklen+&totallen+1 + lda &worklen + sta &worklen+&totallen +.i + pld + tsc + clc + adc #&worklen+&totallen + tcs + aif &len=0,.j + tya +.j + rtl + mend diff --git a/CGC.pas b/CGC.pas index cd0a2e8..bc8ff55 100644 --- a/CGC.pas +++ b/CGC.pas @@ -67,6 +67,24 @@ procedure CnvSX (rec: realrec); extern; { has space for the result } +procedure CnvXLL (var result: longlong; val: extended); extern; + +{ convert a real number to long long } +{ } +{ parameters: } +{ result - longlong to hold the converted value } +{ val - the real value } + + +procedure CnvXULL (var result: longlong; val: extended); extern; + +{ convert a real number to unsigned long long } +{ } +{ parameters: } +{ result - longlong to hold the converted value } +{ val - the real value } + + procedure InitLabels; extern; { initialize the labels array for a procedure } diff --git a/DAG.pas b/DAG.pas index 1ababf9..486aaa1 100644 --- a/DAG.pas +++ b/DAG.pas @@ -11,7 +11,7 @@ unit DAG; interface -{$segment 'CG'} +{$segment 'DAG'} {$LibPrefix '0/obj/'} @@ -49,6 +49,31 @@ function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; +function lshr (x,y: longint): longint; extern; + +{-- External 64-bit math routines; imported from Expression.pas --} +{ Procedures for arithmetic and shifts compute "x := x OP y". } + +procedure umul64 (var x: longlong; y: longlong); extern; + +procedure udiv64 (var x: longlong; y: longlong); extern; + +procedure div64 (var x: longlong; y: longlong); extern; + +procedure umod64 (var x: longlong; y: longlong); extern; + +procedure rem64 (var x: longlong; y: longlong); extern; + +procedure add64 (var x: longlong; y: longlong); extern; + +procedure sub64 (var x: longlong; y: longlong); extern; + +procedure shl64 (var x: longlong; y: integer); extern; + +procedure ashr64 (var x: longlong; y: integer); extern; + +procedure lshr64 (var x: longlong; y: integer); extern; + {---------------------------------------------------------------} function CodesMatch (op1, op2: icptr; exact: boolean): boolean; @@ -224,8 +249,8 @@ if opt1 = cgByte then begin opt1 := cgWord; end {if} else if opt1 = cgUByte then begin - op1^.optype := cgUWord; - opt1 := cgUWord; + op1^.optype := cgWord; + opt1 := cgWord; end {else if} else if opt1 in [cgReal, cgDouble, cgComp] then begin op1^.optype := cgExtended; @@ -236,8 +261,8 @@ if opt2 = cgByte then begin opt2 := cgWord; end {if} else if opt2 = cgUByte then begin - op2^.optype := cgUWord; - opt2 := cgUWord; + op2^.optype := cgWord; + opt2 := cgWord; end {else if} else if opt2 in [cgReal, cgDouble, cgComp] then begin op2^.optype := cgExtended; @@ -877,12 +902,18 @@ case op^.opcode of {check for optimizations of this node} end; {case pc_adr} pc_adq: begin {pc_adq} - if op^.left^.opcode = pc_ldc then - ReverseChildren(op); - if op^.right^.opcode = pc_ldc then begin - if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then - opv := op^.left; - end; {if} + if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin + add64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end {if} + else begin + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {else} end; {case pc_adq} pc_and: begin {pc_and} @@ -1106,6 +1137,14 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := 0; op^.left^.lval := lval; end; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := op^.left^.q; + if op^.left^.qval.lo < 0 then + op^.left^.qval.hi := -1 + else + op^.left^.qval.hi := 0; + op^.left^.q := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.q; op^.left^.q := 0; @@ -1121,6 +1160,11 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := 0; op^.left^.lval := lval; end; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := ord4(op^.left^.q) & $0000FFFF; + op^.left^.qval.hi := 0; + op^.left^.q := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin rval := ord4(op^.left^.q) & $0000FFFF; op^.left^.q := 0; @@ -1136,6 +1180,13 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := q; end; cgLong, cgULong: ; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := op^.left^.lval; + if op^.left^.qval.lo < 0 then + op^.left^.qval.hi := -1 + else + op^.left^.qval.hi := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.lval; op^.left^.lval := 0; @@ -1151,6 +1202,10 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := q; end; cgLong, cgULong: ; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := op^.left^.lval; + op^.left^.qval.hi := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin lval := op^.left^.lval; op^.left^.lval := 0; @@ -1229,6 +1284,10 @@ case op^.opcode of {check for optimizations of this node} op^.left^.rval := 0.0; op^.left^.lval := lval; end; + cgQuad: + CnvXLL(op^.left^.qval, rval); + cgUQuad: + CnvXULL(op^.left^.qval, rval); cgReal,cgDouble,cgComp,cgExtended: ; otherwise: ; end; @@ -1239,8 +1298,8 @@ case op^.opcode of {check for optimizations of this node} [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, cgComp,cgExtended] then if totype.optype in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, - cgComp,cgExtended] then begin + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, + cgReal,cgDouble,cgComp,cgExtended] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} @@ -1286,6 +1345,13 @@ case op^.opcode of {check for optimizations of this node} op^.left^.optype := totype.optype; opv := op^.left; end; {if} + if fromtype.optype in [cgQuad,cgUQuad] then + if totype.optype in + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] + then begin + op^.left^.optype := totype.optype; + opv := op^.left; + end; {if} end {else if} else if op^.q in [$40,$41,$50,$51] then begin {any long type to byte type} @@ -1372,6 +1438,19 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_dvl} + pc_dvq: begin {pc_dvq} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + div64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end {if} + else if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_dvq} + pc_dvr: begin {pc_dvr} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin @@ -1734,6 +1813,21 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_mdl} + pc_mdq: begin {pc_mdq} + if op^.right^.opcode = pc_ldc then + if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then begin + if not SideEffects(op^.left) then begin + op^.right^.qval := longlong0; + opv := op^.right; + end; {if} + end {if} + else if op^.left^.opcode = pc_ldc then + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + rem64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end; {case pc_mdq} + pc_mod: begin {pc_mod} if op^.right^.opcode = pc_ldc then if op^.right^.q = 1 then begin @@ -1814,6 +1908,31 @@ case op^.opcode of {check for optimizations of this node} end; {else} end; {case pc_mpl, pc_uml} + pc_mpq, pc_umq: begin {pc_mpq, pc_umq} + if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin + umul64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end {if} + else begin + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then + opv := op^.left + else if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + begin + if not SideEffects(op^.left) then + opv := op^.right; + end {else if} + else if (op^.right^.qval.lo = -1) and (op^.right^.qval.hi = -1) then + if op^.opcode = pc_mpq then begin + op^.opcode := pc_ngq; + op^.right := nil; + end; {if} + end; {if} + end; {else} + end; {case pc_mpq, pc_umq} + pc_mpr: begin {pc_mpr} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.rval := op^.left^.rval*op^.right^.rval; @@ -1909,6 +2028,19 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_ngl} + pc_ngq: begin {pc_ngq} + if op^.left^.opcode = pc_ldc then begin + with op^.left^.qval do begin + lo := ~lo; + hi := ~hi; + lo := lo + 1; + if lo = 0 then + hi := hi + 1; + end; {with} + opv := op^.left; + end; {if} + end; {case pc_ngq} + pc_ngr: begin {pc_ngr} if op^.left^.opcode = pc_ldc then begin op^.left^.rval := -op^.left^.rval; @@ -1925,7 +2057,12 @@ case op^.opcode of {check for optimizations of this node} end {if} else if op^.left^.optype in [cgLong,cgULong] then begin q := ord(op^.left^.lval = 0); - lval := 0; + op^.left^.q := q; + op^.left^.optype := cgWord; + opv := op^.left; + end {else if} + else if op^.left^.optype in [cgQuad,cgUQuad] then begin + q := ord((op^.left^.qval.lo = 0) and (op^.left^.qval.hi = 0)); op^.left^.q := q; op^.left^.optype := cgWord; opv := op^.left; @@ -2100,7 +2237,11 @@ case op^.opcode of {check for optimizations of this node} pc_sbq: begin {pc_sbq} if op^.left^.opcode = pc_ldc then begin - if (op^.left^.qval.lo = 0) and (op^.left^.qval.hi = 0) then begin + if op^.right^.opcode = pc_ldc then begin + sub64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end {if} + else if (op^.left^.qval.lo = 0) and (op^.left^.qval.hi = 0) then begin op^.opcode := pc_ngq; op^.left := op^.right; op^.right := nil; @@ -2115,7 +2256,11 @@ case op^.opcode of {check for optimizations of this node} pc_shl: begin {pc_shl} if op^.right^.opcode = pc_ldc then begin opcode := op^.left^.opcode; - if opcode = pc_shl then begin + if opcode = pc_ldc then begin + op^.left^.q := op^.left^.q << op^.right^.q; + opv := op^.left; + end {if} + else if opcode = pc_shl then begin if op^.left^.right^.opcode = pc_ldc then begin op^.right^.q := op^.right^.q + op^.left^.right^.q; op^.left := op^.left^.left; @@ -2128,10 +2273,56 @@ case op^.opcode of {check for optimizations of this node} op2^.left := op; opv := op2; PeepHoleOptimization(op2^.left); - end; {else if} + end {else if} + else if op^.right^.q = 0 then + opv := op^.left; end; {if} end; {case pc_shl} + pc_shr: begin {pc_shr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.q := op^.left^.q >> op^.right^.q; + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_shr} + + pc_sll: begin {pc_sll} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.lval := op^.left^.lval << op^.right^.lval; + opv := op^.left; + end {if} + else if op^.right^.lval = 0 then + opv := op^.left; + end; {if} + end; {case pc_sll} + + pc_slr: begin {pc_slr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.lval := op^.left^.lval >> op^.right^.lval; + opv := op^.left; + end {if} + else if op^.right^.lval = 0 then + opv := op^.left; + end; {if} + end; {case pc_slr} + + pc_slq: begin {pc_slq} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + shl64(op^.left^.qval, op^.right^.q); + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_slq} + pc_sro, pc_str: begin {pc_sro, pc_str} if op^.optype in [cgReal,cgDouble,cgExtended] then RealStoreOptimizations(op, op^.left); @@ -2156,6 +2347,17 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_sto} + pc_sqr: begin {pc_sqr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + ashr64(op^.left^.qval, op^.right^.q); + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_sqr} + pc_tjp: begin {pc_tjp} opcode := op^.left^.opcode; if opcode = pc_ldc then begin @@ -2259,6 +2461,19 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_udl} + pc_udq: begin {pc_udq} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + udiv64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end {if} + else if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_udq} + pc_uim: begin {pc_uim} if op^.right^.opcode = pc_ldc then if op^.right^.q = 1 then begin @@ -2305,6 +2520,55 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_ulm} + pc_uqm: begin {pc_uqm} + if op^.right^.opcode = pc_ldc then + if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then begin + if not SideEffects(op^.left) then begin + op^.right^.qval := longlong0; + opv := op^.right; + end; {if} + end {if} + else if op^.left^.opcode = pc_ldc then + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + umod64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end; {case pc_uqm} + + pc_usr: begin {pc_usr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + lval := lshr(op^.left^.q & $0000FFFF, op^.right^.q); + op^.left^.q := long(lval).lsw; + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_usr} + + pc_vsr: begin {pc_vsr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.lval := lshr(op^.left^.lval, op^.right^.lval); + opv := op^.left; + end {if} + else if op^.right^.lval = 0 then + opv := op^.left; + end; {if} + end; {case pc_vsr} + + pc_wsr: begin {pc_wsr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + lshr64(op^.left^.qval, op^.right^.q); + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_wsr} + otherwise: ; end; {case} end; {PeepHoleOptimization} From 5ed820717ed14c5eda4c84533c3005ef6c42f6b1 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 18 Feb 2021 23:27:18 -0600 Subject: [PATCH 55/68] Implement conversions from long long to other types in the optimizer. The code of PeepHoleOptimization is now big enough that it triggers bogus "Relative address out of range" range errors from the linker. This is a linker bug and should be fixed there. --- CGC.asm | 68 ++++++++++++++++++++++++++++++++++++++++++++ CGC.macros | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++ CGC.pas | 16 +++++++++++ DAG.pas | 82 +++++++++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 229 insertions(+), 13 deletions(-) diff --git a/CGC.asm b/CGC.asm index 716a217..4b9867f 100644 --- a/CGC.asm +++ b/CGC.asm @@ -139,6 +139,74 @@ CnvXULL start cg return end +**************************************************************** +* +* function CnvLLX (val: longlong): extended; +* +* convert a long long to a real number +* +* Inputs: +* val - the long long value +* +**************************************************************** + +CnvLLX start cg + + subroutine (4:val),0 + + ph8 [val] + jsl ~CnvLongLongReal + pla + sta >rval + pla + sta >rval+2 + pla + sta >rval+4 + pla + sta >rval+6 + pla + sta >rval+8 + + lla val,rval + return 4:val + +rval ds 10 + end + +**************************************************************** +* +* function CnvULLX (val: longlong): extended; +* +* convert an unsigned long long to a real number +* +* Inputs: +* val - the unsigned long long value +* +**************************************************************** + +CnvULLX start cg + + subroutine (4:val),0 + + ph8 [val] + jsl ~CnvULongLongReal + pla + sta >rval + pla + sta >rval+2 + pla + sta >rval+4 + pla + sta >rval+6 + pla + sta >rval+8 + + lla val,rval + return 4:val + +rval ds 10 + end + datachk off **************************************************************** * diff --git a/CGC.macros b/CGC.macros index 3f9e3c4..4613e41 100644 --- a/CGC.macros +++ b/CGC.macros @@ -359,3 +359,79 @@ .j rtl mend + macro +&l lla &ad1,&ad2 +&l anop + lcla &lb + lclb &la + aif s:longa,.a + rep #%00100000 + longa on +&la setb 1 +.a + lda #&ad2 +&lb seta c:&ad1 +.b + sta &ad1(&lb) +&lb seta &lb-1 + aif &lb,^b + lda #^&ad2 +&lb seta c:&ad1 +.c + sta 2+&ad1(&lb) +&lb seta &lb-1 + aif &lb,^c + aif &la=0,.d + sep #%00100000 + longa off +.d + mend + macro +&l ph8 &n1 + lclc &c +&l anop +&c amid &n1,1,1 + aif s:longa=1,.a + rep #%00100000 +.a + aif "&c"="#",.d + aif "&c"="[",.b + aif "&c"<>"{",.c +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.g +&n1 amid &n1,2,l:&n1-2 +&n1 setc (&n1) +.b + ldy #6 +~&SYSCNT lda &n1,y + pha + dey + dey + bpl ~&SYSCNT + ago .e +.c + ldx #6 +~&SYSCNT lda &n1,x + pha + dex + dex + bpl ~&SYSCNT + ago .e +.d +&n1 amid &n1,2,l:&n1-1 + bra ~b&SYSCNT +~a&SYSCNT dc i8"&n1" +~b&SYSCNT ldx #6 +~c&SYSCNT lda ~a&SYSCNT,x + pha + dex + dex + bpl ~c&SYSCNT +.e + aif s:longa=1,.f + sep #%00100000 +.f + mexit +.g + mnote "Missing closing '}'",16 + mend diff --git a/CGC.pas b/CGC.pas index bc8ff55..348e1ff 100644 --- a/CGC.pas +++ b/CGC.pas @@ -85,6 +85,22 @@ procedure CnvXULL (var result: longlong; val: extended); extern; { val - the real value } +function CnvLLX (val: longlong): extended; extern; + +{ convert a long long to a real number } +{ } +{ parameters: } +{ val - the long long value } + + +function CnvULLX (val: longlong): extended; extern; + +{ convert an unsigned long long to a real number } +{ } +{ parameters: } +{ val - the unsigned long long value } + + procedure InitLabels; extern; { initialize the labels array for a procedure } diff --git a/DAG.pas b/DAG.pas index 63db1ce..49e87ee 100644 --- a/DAG.pas +++ b/DAG.pas @@ -1128,6 +1128,7 @@ case op^.opcode of {check for optimizations of this node} op^.q := (op^.q & $FF0F) | (fromtype.i << 4); end; {if} if op^.left^.opcode = pc_ldc then begin + doit := true; case fromtype.optype of cgByte,cgWord: case totype.optype of @@ -1217,6 +1218,60 @@ case op^.opcode of {check for optimizations of this node} end; otherwise: ; end; {case} + cgQuad: + case totype.optype of + cgByte,cgUByte,cgWord,cgUWord: begin + q := long(op^.left^.qval.lo).lsw; + op^.left^.qval := longlong0; + op^.left^.q := q; + end; + cgLong, cgULong: begin + lval := op^.left^.qval.lo; + op^.left^.qval := longlong0; + op^.left^.lval := lval; + end; + cgQuad,cgUQuad: ; + cgDouble,cgExtended: begin + {only convert values exactly representable in double} + rval := CnvLLX(op^.left^.qval); + if rval = CnvLLX(op^.left^.qval) then begin + op^.left^.qval := longlong0; + op^.left^.rval := rval; + end {if} + else + doit := false; + end; + cgReal,cgComp: + doit := false; + otherwise: ; + end; {case} + cgUQuad: + case totype.optype of + cgByte,cgUByte,cgWord,cgUWord: begin + q := long(op^.left^.qval.lo).lsw; + op^.left^.qval := longlong0; + op^.left^.q := q; + end; + cgLong, cgULong: begin + lval := op^.left^.qval.lo; + op^.left^.qval := longlong0; + op^.left^.lval := lval; + end; + cgQuad,cgUQuad: ; + cgDouble,cgExtended: begin + {only convert values exactly representable in double} + rval := CnvULLX(op^.left^.qval); + if rval = CnvULLX(op^.left^.qval) then begin + op^.left^.qval := longlong0; + op^.left^.rval := rval; + end {if} + else + doit := false; + end; + cgReal,cgComp: + doit := false; + otherwise: ; + end; {case} cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.rval; case totype.optype of @@ -1294,21 +1349,22 @@ case op^.opcode of {check for optimizations of this node} end; {case} otherwise: ; end; {case} - if fromtype.optype in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, - cgComp,cgExtended] then - if totype.optype in + if doit then + if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, - cgReal,cgDouble,cgComp,cgExtended] then begin - op^.left^.optype := totype.optype; - if totype.optype in [cgByte,cgUByte] then begin - op^.left^.q := op^.left^.q & $00FF; - if totype.optype = cgByte then - if (op^.left^.q & $0080) <> 0 then - op^.left^.q := op^.left^.q | $FF00; + cgReal,cgDouble,cgComp,cgExtended] then + if totype.optype in + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, + cgReal,cgDouble,cgComp,cgExtended] then begin + op^.left^.optype := totype.optype; + if totype.optype in [cgByte,cgUByte] then begin + op^.left^.q := op^.left^.q & $00FF; + if totype.optype = cgByte then + if (op^.left^.q & $0080) <> 0 then + op^.left^.q := op^.left^.q | $FF00; + end; {if} + opv := op^.left; end; {if} - opv := op^.left; - end; {if} end {if} else if op^.left^.opcode = pc_cnv then begin doit := false; From 75c7cd95d3c4322ee91b312af3acd41323ba94e1 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 19 Feb 2021 21:57:31 -0600 Subject: [PATCH 56/68] Statically evaluate casts to and from long long. --- Expression.pas | 70 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 48 insertions(+), 22 deletions(-) diff --git a/Expression.pas b/Expression.pas index 97463e3..12ea149 100644 --- a/Expression.pas +++ b/Expression.pas @@ -313,6 +313,16 @@ function sle64(a,b: longlong): integer; extern; function sgt64(a,b: longlong): integer; extern; +{-- External conversion functions; imported from CGC.pas -------} + +procedure CnvXLL (var result: longlong; val: extended); extern; + +procedure CnvXULL (var result: longlong; val: extended); extern; + +function CnvLLX (val: longlong): extended; extern; + +function CnvULLX (val: longlong): extended; extern; + {---------------------------------------------------------------} function Unary(tp: baseTypeEnum): baseTypeEnum; @@ -934,7 +944,7 @@ var { do an operation } - label 1,2; + label 1,2,3; var baseType: baseTypeEnum; {base type of value to cast} @@ -946,6 +956,7 @@ var op1,op2: longint; {for evaluating constant expressions} rop1,rop2: double; {for evaluating double expressions} llop1, llop2: longlong; {for evaluating long long expressions} + extop1: extended; {temporary for conversions} tp: typePtr; {cast type} unsigned: boolean; {is the term unsigned?} @@ -1541,27 +1552,32 @@ var else if op^.token.kind = castoper then begin class := op^.left^.token.class; - if class in [intConstant,longConstant,doubleConstant] then begin + if class in [intConstant,longConstant,longlongconstant, + doubleConstant] then begin tp := op^.castType; while tp^.kind = definedType do tp := tp^.dType; if tp^.kind = scalarType then begin baseType := tp^.baseType; - if baseType < cgString then begin + if (baseType < cgString) or (baseType in [cgQuad,cgUQuad]) + then begin if class = doubleConstant then begin rop1 := RealVal(op^.left^.token); - op1 := trunc(rop1); - end {if} - else {if class in [intConstant,longConstant] then} begin - op1 := IntVal(op^.left^.token); - if op1 >= 0 then - rop1 := op1 - else if op^.left^.token.kind = uintConst then - rop1 := (op1 & $7FFF) + 32768.0 - else if op^.left^.token.kind = ulongConst then - rop1 := (op1 & $7FFFFFFF) + 2147483648.0 + if baseType = cgUQuad then + CnvXULL(llop1, rop1) else - rop1 := op1; + CnvXLL(llop1, rop1); + end {if} + else begin {handle integer constants} + GetLongLongVal(llop1, op^.left^.token); + if op^.left^.token.kind = ulonglongconst then + extop1 := CnvULLX(llop1) + else + extop1 := CnvLLX(llop1); + rop1 := extop1; + if baseType in [cgExtended,cgComp] then + if rop1 <> extop1 then + goto 3; end; {else if} dispose(op^.left); op^.left := nil; @@ -1571,7 +1587,7 @@ var if tp^.cType = ctBool then op^.token.ival := ord(rop1 <> 0.0) else - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; if baseType = cgByte then with op^.token do begin ival := ival & $00FF; @@ -1582,23 +1598,33 @@ var else if baseType = cgUWord then begin op^.token.kind := uintConst; op^.token.class := intConstant; - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; end {else if} else if baseType = cgUByte then begin op^.token.kind := intConst; op^.token.class := intConstant; - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; op^.token.ival := op^.token.ival & $00FF; end {else if} else if baseType = cgLong then begin op^.token.kind := longConst; op^.token.class := longConstant; - op^.token.lval := op1; + op^.token.lval := llop1.lo; end {else if} else if baseType = cgULong then begin op^.token.kind := ulongConst; op^.token.class := longConstant; - op^.token.lval := op1; + op^.token.lval := llop1.lo; + end {else if} + else if baseType = cgQuad then begin + op^.token.kind := longlongConst; + op^.token.class := longlongConstant; + op^.token.qval := llop1; + end {else if} + else if baseType = cgUQuad then begin + op^.token.kind := ulonglongConst; + op^.token.class := longlongConstant; + op^.token.qval := llop1; end {else if} else begin op^.token.kind := doubleConst; @@ -1606,7 +1632,7 @@ var op^.token.rval := rop1; end; {else if} end; {if} - end; {if} +3: end; {if} end; {if} end {else if castoper} @@ -1773,8 +1799,8 @@ if token.kind in startExpression then begin if op^.token.kind = castoper then if op^.casttype^.kind = scalarType then if op^.casttype^.baseType in [cgByte,cgUByte, - cgWord,cgUWord,cgLong,cgULong] then - goto 3; + cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] + then goto 3; while op <> nil do begin if op^.token.kind = sizeofsy then goto 3; From 58f2ebddecd12cbdeb8d0ca8fa5b8ddbc4e35f28 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Fri, 19 Feb 2021 23:46:57 -0600 Subject: [PATCH 57/68] Allow static evaluation of ? : expressions with long long operands. --- Expression.pas | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/Expression.pas b/Expression.pas index 12ea149..37d10b4 100644 --- a/Expression.pas +++ b/Expression.pas @@ -1101,13 +1101,14 @@ var op^.right := Pop; op^.middle := Pop; op^.left := Pop; - if op^.right^.token.kind in - [intconst,uintconst,longconst,ulongconst] then - if op^.left^.token.kind in - [intconst,uintconst,longconst,ulongconst] then - if op^.middle^.token.kind in - [intconst,uintconst,longconst,ulongconst] then begin - if IntVal(op^.left^.token) <> 0 then + if op^.right^.token.kind in [intconst,uintconst, + longconst,ulongconst,longlongconst,ulonglongconst] then + if op^.left^.token.kind in [intconst,uintconst, + longconst,ulongconst,longlongconst,ulonglongconst] then + if op^.middle^.token.kind in [intconst,uintconst, + longconst,ulongconst,longlongconst,ulonglongconst] then begin + GetLongLongVal(llop1, op^.left^.token); + if (llop1.lo <> 0) or (llop1.hi <> 0) then op^.token := op^.middle^.token else op^.token := op^.right^.token; From 3c0e4baf7821bd7d0e8ddcaed12f3532a6beedc7 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 20 Feb 2021 17:07:47 -0600 Subject: [PATCH 58/68] Basic infrastructure for using different quadword locations in codegen. For the moment, this does not really do anything, but it lays the groundwork for not always having to load quadword values to the stack before operating on or storing them. --- Gen.pas | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 5 deletions(-) diff --git a/Gen.pas b/Gen.pas index 4277bdd..d03458e 100644 --- a/Gen.pas +++ b/Gen.pas @@ -39,12 +39,14 @@ procedure Gen (blk: blockPtr); implementation const - A_X = 1; {longword locations} + {longword/quadword locations} + A_X = 1; {longword only} onStack = 2; inPointer = 4; localAddress = 8; globalLabel = 16; constant = 32; + nowhere = 64; {stack frame locations} {---------------------} @@ -60,10 +62,20 @@ type disp: integer; {fixed displacement/local addr} lval: longint; {value} lab: stringPtr; {global label name} + end; + {possible locations for 8 byte values} + {note: these always have fixed disp} + quadType = record {description of current 8 byte value} + preference: integer; {where you want the value} + where: integer; {where the value is at} + disp: integer; {fixed displacement/local addr} + lval: longlong; {value} + lab: stringPtr; {global label name} end; var gLong: longType; {info about last long value} + gQuad: quadType; {info about last quad value} namePushed: boolean; {has a name been pushed in this proc?} skipLoad: boolean; {skip load for a pc_lli, etc?} stackSaveDepth: integer; {nesting depth of saved stack positions} @@ -689,7 +701,9 @@ procedure GenAdqSbq (op: icptr); { op - pc_adq or pc_sbq operation } begin {GenAdqSbq} +gQuad.preference := onStack; GenTree(op^.right); +gQuad.preference := onStack; GenTree(op^.left); if op^.opcode = pc_adq then begin GenImplied(m_clc); @@ -721,6 +735,7 @@ else {if op^.opcode = pc_sbq then} begin GenNative(m_sbc_s, direct, 7, nil, 0); GenNative(m_sta_s, direct, 7, nil, 0); end; {else} +gQuad.where := onStack; end; {GenAdqSbq} @@ -1162,11 +1177,15 @@ else cgQuad: begin if op^.opcode = pc_geq then begin + gQuad.preference := onStack; GenTree(op^.left); + gQuad.preference := onStack; GenTree(op^.right); end {if} else {if op^.opcode = pc_grt then} begin + gQuad.preference := onStack; GenTree(op^.right); + gQuad.preference := onStack; GenTree(op^.left); end; {else} GenCall(88); @@ -1192,7 +1211,9 @@ else end; {case optype of cgQuad} cgUQuad: begin + gQuad.preference := onStack; GenTree(op^.left); + gQuad.preference := onStack; GenTree(op^.right); if op^.opcode = pc_geq then GenNative(m_ldx_imm, immediate, 1, nil, 0) @@ -1355,6 +1376,7 @@ begin {GenCnv} lLong := gLong; gLong.preference := onStack+A_X+constant; gLong.where := onStack; +gQuad.preference := onStack; if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin op^.q := (op^.q & $000F) | (cReal * 16); fromReal := true; @@ -1364,6 +1386,7 @@ else if (op^.q & $000F) in [cDouble,cExtended,cComp] then op^.q := (op^.q & $00F0) | cReal; GenTree(op^.left); +gQuad.where := onStack; {unless overridden below} if op^.q in [wordToLong,wordToUlong] then begin lab1 := GenLabel; GenNative(m_ldx_imm, immediate, 0, nil, 0); @@ -1991,7 +2014,9 @@ else end; {case optype of cgReal..cgExtended} cgQuad,cgUQuad: begin + gQuad.preference := onStack; GenTree(op^.left); + gQuad.preference := onStack; GenTree(op^.right); lab1 := GenLabel; @@ -2931,6 +2956,7 @@ case optype of GenImplied(m_pha); end; {else} end; {else} + gQuad.where := onStack; end; {case cgQuad,cgUQuad} otherwise: Error(cge1); end; {case} @@ -3773,6 +3799,7 @@ case optype of end; {case CGLong, cgULong} cgQuad, cgUQuad: begin + gQuad.preference := onStack; GenTree(op^.left); if opcode = pc_sro then GenImplied(m_pla) @@ -3806,6 +3833,8 @@ case optype of GenNative(m_sta_abs, absolute, q+6, lab, 0) else GenNative(m_sta_long, longabsolute, q+6, lab, 0); + if opcode = pc_cpo then + gQuad.where := onStack; end; {case cgQuad, cgUQuad} end; {case} end; {GenSroCpo} @@ -3920,6 +3949,7 @@ case optype of end; {case cgReal,cgDouble,cgComp,cgExtended} cgQuad,cgUQuad: begin + gQuad.preference := onStack; GenTree(op^.right); gLong.preference := A_X; GenTree(op^.left); @@ -3954,6 +3984,8 @@ case optype of else {if op^.opcode = pc_cpi then} GenNative(m_lda_s, direct, 7, nil, 0); GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + if op^.opcode = pc_cpi then + gQuad.where := onStack; end; {case cgQuad,cgUQuad} cgLong,cgULong: begin @@ -4454,6 +4486,7 @@ case optype of end; cgQuad, cgUQuad: begin + gQuad.preference := onStack; GenTree(op^.left); if disp < 250 then begin if op^.opcode = pc_str then @@ -4500,6 +4533,8 @@ case optype of GenNative(m_lda_s, direct, 7, nil, 0); GenNative(m_sta_dirX, direct, 6, nil, 0); end; {else} + if op^.opcode = pc_cop then + gQuad.where := onStack; end; otherwise: Error(cge1); @@ -4545,6 +4580,7 @@ procedure GenUnaryQuad (op: icptr); { generate a pc_bnq or pc_ngq } begin {GenUnaryQuad} +gQuad.preference := onStack; GenTree(op^.left); case op^.opcode of {do the operation} @@ -4580,6 +4616,7 @@ case op^.opcode of {do the operation} GenNative(m_sta_s, direct, 7, nil, 0); end; {case pc_ngq} end; {case} +gQuad.where := onStack; end; {GenUnaryQuad} @@ -4774,7 +4811,9 @@ procedure GenTree {op: icptr}; end; {GenOp} begin {GenBinQuad} + gQuad.preference := onStack; GenTree(op^.left); + gQuad.preference := onStack; GenTree(op^.right); case op^.opcode of pc_bqr: GenOp(m_ora_s); @@ -4833,6 +4872,7 @@ procedure GenTree {op: icptr}; otherwise: Error(cge1); end; {case} + gQuad.where := onStack; end; {GenBinQuad} @@ -4982,6 +5022,7 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; + gQuad.where := onStack; SaveRetValue(op^.optype); argsSize := lArgsSize; end; {GenCui} @@ -5076,6 +5117,7 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; + gQuad.where := onStack; SaveRetValue(op^.optype); argsSize := lArgsSize; end; {GenCup} @@ -5402,6 +5444,7 @@ procedure GenTree {op: icptr}; GenNative(m_pea, immediate, long(op^.qval.hi).lsw, nil, 0); GenNative(m_pea, immediate, long(op^.qval.lo).msw, nil, 0); GenNative(m_pea, immediate, long(op^.qval.lo).lsw, nil, 0); + gQuad.where := onStack; end; otherwise: @@ -5500,6 +5543,7 @@ procedure GenTree {op: icptr}; GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0); GenImplied(m_pha); end; {else} + gQuad.where := onStack; end; {case cgQuad,cgUQuad} otherwise: @@ -5573,6 +5617,7 @@ procedure GenTree {op: icptr}; GenNative(m_pei_dir, direct, disp+2, nil, 0); GenNative(m_pei_dir, direct, disp, nil, 0); end; {else} + gQuad.where := onStack; end; cgLong, cgULong: begin @@ -5929,6 +5974,7 @@ procedure GenTree {op: icptr}; begin {GenPop} glong.preference := A_X; {generate the operand} + gQuad.preference := nowhere; isIncLoad := op^.left^.opcode in [pc_lil,pc_lli,pc_ldl,pc_lld,pc_gil,pc_gli,pc_gdl,pc_gld, pc_iil,pc_ili,pc_idl,pc_ild]; @@ -5954,10 +6000,12 @@ procedure GenTree {op: icptr}; {else do nothing} cgQuad, cgUQuad: begin - GenImplied(m_tsc); - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); + if gQuad.where = onStack then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} end; cgReal, cgDouble, cgComp, cgExtended: begin @@ -6301,6 +6349,7 @@ procedure GenTree {op: icptr}; otherwise: Error(cge1); end; {case} glong.preference := onStack; {generate the operand} + gQuad.preference := onStack; GenTree(op^.left); if op^.optype in {do the stk} [cgByte, cgUByte, cgWord, cgUWord] then From daff1978116955ebd9049eca7b268ea2de397784 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sat, 20 Feb 2021 23:38:42 -0600 Subject: [PATCH 59/68] Optimize some quad ops to use interleaved loads and stores. This allows them to bypass the intermediate step of loading the value onto the stack. Currently, this only works for simple cases where a value is loaded and immediately stored. --- Gen.pas | 487 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 310 insertions(+), 177 deletions(-) diff --git a/Gen.pas b/Gen.pas index d03458e..31f7be7 100644 --- a/Gen.pas +++ b/Gen.pas @@ -55,7 +55,7 @@ const type {possible locations for 4 byte values} longType = record {description of current four byte value} - preference: integer; {where you want the value} + preference: integer; {where you want the value (bitmask)} where: integer; {where the value is at} fixedDisp: boolean; {is the displacement a fixed value?} isLong: boolean; {is long addr required for named labs?} @@ -66,7 +66,7 @@ type {possible locations for 8 byte values} {note: these always have fixed disp} quadType = record {description of current 8 byte value} - preference: integer; {where you want the value} + preference: integer; {where you want the value (single value)} where: integer; {where the value is at} disp: integer; {fixed displacement/local addr} lval: longlong; {value} @@ -238,6 +238,61 @@ else {if icode^.opcode in [pc_ldo, pc_sro] then} end; {DoOp} +procedure StoreWordOfQuad(offset: integer); + +{ Store one word of a quad value to the location specified by } +{ gQuad.preference. The word value to store must be in A. } +{ } +{ The generated code may modify X, and may set Y to offset. } +{ It does not modify A or the carry flag. } +{ } +{ parameters: } +{ offset - offset of the word to store (0, 2, 4, or 6) } +{ } +{ Note: If gQuad.preference is onStack, this just generates a } +{ PHA. That is suitable if loading a value starting from } +{ the most significant word, but not in other cases. For } +{ other gQuad.preference values, any order is okay. } + +begin {StoreWordOfQuad} +case gQuad.preference of + localAddress: begin + if gQuad.disp+offset <= 255 then + GenNative(m_sta_dir, direct, gQuad.disp+offset, nil, 0) + else begin + GenNative(m_ldx_imm, immediate, gQuad.disp+offset, nil, 0); + GenNative(m_sta_dirX, direct, 0, nil, 0); + end; {else} + end; + + globalLabel: begin + if smallMemoryModel then + GenNative(m_sta_abs, absolute, gQuad.disp+offset, gQuad.lab, 0) + else + GenNative(m_sta_long, longabsolute, gQuad.disp+offset, gQuad.lab, 0); + end; + + inPointer: begin + if (gQuad.disp > 255) or (gQuad.disp < 0) then + Error(cge1); + if offset = 0 then + GenNative(m_sta_indl, direct, gQuad.disp, nil, 0) + else begin + GenNative(m_ldy_imm, immediate, offset, nil, 0); + GenNative(m_sta_indly, direct, gQuad.disp, nil, 0); + end; {else} + end; + + onStack: + GenImplied(m_pha); + + nowhere: ; {discard the value} + + otherwise: Error(cge1); + end; {case} +end; {StoreWordOfQuad} + + procedure GetPointer (op: icptr); { convert a tree into a usable pointer for indirect } @@ -1376,7 +1431,10 @@ begin {GenCnv} lLong := gLong; gLong.preference := onStack+A_X+constant; gLong.where := onStack; -gQuad.preference := onStack; +if op^.q in [quadToVoid,uQuadToVoid] then + gQuad.preference := nowhere +else + gQuad.preference := onStack; if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin op^.q := (op^.q & $000F) | (cReal * 16); fromReal := true; @@ -1386,7 +1444,6 @@ else if (op^.q & $000F) in [cDouble,cExtended,cComp] then op^.q := (op^.q & $00F0) | cReal; GenTree(op^.left); -gQuad.where := onStack; {unless overridden below} if op^.q in [wordToLong,wordToUlong] then begin lab1 := GenLabel; GenNative(m_ldx_imm, immediate, 0, nil, 0); @@ -1552,6 +1609,7 @@ else if op^.q in [ubyteToQuad,ubyteToUQuad,uwordToQuad,uwordToUQuad] then begin GenImplied(m_phy); GenImplied(m_phy); GenImplied(m_pha); + gQuad.where := onStack; end {else if} else if op^.q in [byteToQuad,byteToUQuad] then begin lab1 := GenLabel; @@ -1565,6 +1623,7 @@ else if op^.q in [byteToQuad,byteToUQuad] then begin GenImplied(m_phx); GenImplied(m_phx); GenImplied(m_pha); + gQuad.where := onStack; end {else if} else if op^.q in [wordToQuad,wordToUQuad] then begin lab1 := GenLabel; @@ -1577,6 +1636,7 @@ else if op^.q in [wordToQuad,wordToUQuad] then begin GenImplied(m_phx); GenImplied(m_phx); GenImplied(m_pha); + gQuad.where := onStack; end {else if} else if op^.q in [ulongToQuad,ulongToUQuad] then begin if gLong.where = A_X then begin @@ -1599,6 +1659,7 @@ else if op^.q in [ulongToQuad,ulongToUQuad] then begin GenImplied(m_phx); GenImplied(m_pha); end; {else} + gQuad.where := onStack; end {else if} else if op^.q in [longToQuad,longToUQuad] then begin if gLong.where = constant then begin @@ -1632,11 +1693,16 @@ else if op^.q in [longToQuad,longToUQuad] then begin GenImplied(m_phx); GenImplied(m_pha); end; {else} + gQuad.where := onStack; + end {else if} +else if op^.q = realToQuad then begin + GenCall(89); + gQuad.where := onStack; + end {else if} +else if op^.q = realToUQuad then begin + GenCall(90); + gQuad.where := onStack; end {else if} -else if op^.q = realToQuad then - GenCall(89) -else if op^.q = realToUQuad then - GenCall(90) else if op^.q in [quadToWord,uquadToWord,quadToUWord,uquadToUWord] then begin GenImplied(m_pla); GenImplied(m_plx); @@ -1677,10 +1743,12 @@ else if op^.q in [quadToLong,uquadToLong,quadToULong,uquadToULong] then begin end; {else} end {else if} else if op^.q in [quadToVoid,uquadToVoid] then begin - GenImplied(m_tsc); - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); + if gQuad.where = onStack then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} end {else if} else if op^.q = quadToReal then GenCall(83) @@ -2583,6 +2651,7 @@ procedure GenInd (op: icptr); var lab1: integer; {label} lLong: longType; {requested address type} + lQuad: quadType; {requested quad address type} optype: baseTypeEnum; {op^.optype} q: integer; {op^.q} @@ -2794,23 +2863,26 @@ case optype of end; {case cgByte,cgUByte,cgWord,cgUWord} cgQuad,cgUQuad: begin + lQuad := gQuad; GetPointer(op^.left); + gQuad := lQuad; + gQuad.where := gQuad.preference; {unless overridden later} if gLong.where = inPointer then begin if q = 0 then begin if gLong.fixedDisp then begin GenNative(m_ldy_imm, immediate, 6, nil, 0); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenNative(m_lda_indl, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end {if} else begin GenImplied(m_tya); @@ -2818,38 +2890,38 @@ case optype of GenNative(m_adc_imm, immediate, 6, nil, 0); GenImplied(m_tay); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end; {else} end {if q = 0} else begin if gLong.fixedDisp then begin GenNative(m_ldy_imm, immediate, q+6, nil, 0); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end {if} else begin GenImplied(m_tya); @@ -2857,19 +2929,19 @@ case optype of GenNative(m_adc_imm, immediate, q+6, nil, 0); GenImplied(m_tay); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end; {else} end; {else} end {if glong.where = inPointer} @@ -2877,12 +2949,25 @@ case optype of gLong.disp := gLong.disp+q; if gLong.fixedDisp then if (gLong.disp < 250) and (gLong.disp >= 0) then begin - GenNative(m_pei_dir, direct, gLong.disp+6, nil, 0); - GenNative(m_pei_dir, direct, gLong.disp+4, nil, 0); - GenNative(m_pei_dir, direct, gLong.disp+2, nil, 0); - GenNative(m_pei_dir, direct, gLong.disp, nil, 0); + if gQuad.preference = onStack then begin + GenNative(m_pei_dir, direct, gLong.disp+6, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp+4, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp+2, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp, nil, 0); + end {if} + else begin + GenNative(m_lda_dir, direct, gLong.disp+6, nil, 0); + StoreWordOfQuad(6); + GenNative(m_lda_dir, direct, gLong.disp+4, nil, 0); + StoreWordOfQuad(4); + GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_dir, direct, gLong.disp, nil, 0); + StoreWordOfQuad(0); + end; {else} end {if} else begin + gQuad.where := onStack; GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); GenNative(m_lda_dirX, direct, 6, nil, 0); GenImplied(m_pha); @@ -2894,6 +2979,7 @@ case optype of GenImplied(m_pha); end {else} else begin + gQuad.where := onStack; if (gLong.disp >= 250) or (gLong.disp < 0) then begin GenImplied(m_txa); GenImplied(m_clc); @@ -2916,26 +3002,27 @@ case optype of if gLong.fixedDisp then if smallMemoryModel then begin GenNative(m_lda_abs, absolute, gLong.disp+6, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenNative(m_lda_abs, absolute, gLong.disp+4, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenNative(m_lda_abs, absolute, gLong.disp+2, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end {if} else begin GenNative(m_lda_long, longAbs, gLong.disp+6, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenNative(m_lda_long, longAbs, gLong.disp+4, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); end {else} else if smallMemoryModel then begin + gQuad.where := onStack; GenNative(m_lda_absX, absolute, gLong.disp+6, gLong.lab, 0); GenImplied(m_pha); GenNative(m_lda_absX, absolute, gLong.disp+4, gLong.lab, 0); @@ -2946,6 +3033,7 @@ case optype of GenImplied(m_pha); end {if} else begin + gQuad.where := onStack; GenNative(m_lda_longX, longAbs, gLong.disp+6, gLong.lab, 0); GenImplied(m_pha); GenNative(m_lda_longX, longAbs, gLong.disp+4, gLong.lab, 0); @@ -2956,7 +3044,6 @@ case optype of GenImplied(m_pha); end; {else} end; {else} - gQuad.where := onStack; end; {case cgQuad,cgUQuad} otherwise: Error(cge1); end; {case} @@ -3799,42 +3886,48 @@ case optype of end; {case CGLong, cgULong} cgQuad, cgUQuad: begin - gQuad.preference := onStack; + if opcode = pc_sro then begin + gQuad.preference := globalLabel; + gQuad.lab := lab; + gQuad.disp := q; + end {if} + else {if opcode = pc_cpo then} + gQuad.preference := onStack; GenTree(op^.left); - if opcode = pc_sro then - GenImplied(m_pla) - else {if opcode = pc_cpo then} - GenNative(m_lda_s, direct, 1, nil, 0); - if smallMemoryModel then - GenNative(m_sta_abs, absolute, q, lab, 0) - else - GenNative(m_sta_long, longabsolute, q, lab, 0); - if opcode = pc_sro then - GenImplied(m_pla) - else {if opcode = pc_cpo then} - GenNative(m_lda_s, direct, 3, nil, 0); - if smallMemoryModel then - GenNative(m_sta_abs, absolute, q+2, lab, 0) - else - GenNative(m_sta_long, longabsolute, q+2, lab, 0); - if opcode = pc_sro then - GenImplied(m_pla) - else {if opcode = pc_cpo then} - GenNative(m_lda_s, direct, 5, nil, 0); - if smallMemoryModel then - GenNative(m_sta_abs, absolute, q+4, lab, 0) - else - GenNative(m_sta_long, longabsolute, q+4, lab, 0); - if opcode = pc_sro then - GenImplied(m_pla) - else {if opcode = pc_cpo then} - GenNative(m_lda_s, direct, 7, nil, 0); - if smallMemoryModel then - GenNative(m_sta_abs, absolute, q+6, lab, 0) - else - GenNative(m_sta_long, longabsolute, q+6, lab, 0); - if opcode = pc_cpo then - gQuad.where := onStack; + if gQuad.where = onStack then begin + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 1, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q, lab, 0) + else + GenNative(m_sta_long, longabsolute, q, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 3, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+2, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+2, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 5, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+4, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+4, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 7, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+6, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+6, lab, 0); + end; {if} end; {case cgQuad, cgUQuad} end; {case} end; {GenSroCpo} @@ -3950,42 +4043,52 @@ case optype of cgQuad,cgUQuad: begin gQuad.preference := onStack; + if opcode = pc_sto then + if op^.left^.opcode = pc_lod then begin + disp := LabelToDisp(op^.left^.r) + op^.left^.q; + if disp <= 255 then begin + gQuad.preference := inPointer; + gQuad.disp := disp; + end; {if} + end; {if} GenTree(op^.right); - gLong.preference := A_X; - GenTree(op^.left); - if gLong.where = onStack then begin - GenImplied(m_pla); - GenImplied(m_plx); + if gQuad.where = onStack then begin + gLong.preference := A_X; + GenTree(op^.left); + if gLong.where = onStack then begin + GenImplied(m_pla); + GenImplied(m_plx); + end; {if} + GenNative(m_sta_dir, direct, dworkLoc, nil, 0); + GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_indl, direct, dworkLoc, nil, 0); + GenNative(m_ldy_imm, immediate, 2, nil, 0); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + GenImplied(m_iny); + GenImplied(m_iny); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + GenImplied(m_iny); + GenImplied(m_iny); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + if op^.opcode = pc_cpi then + gQuad.where := onStack; end; {if} - GenNative(m_sta_dir, direct, dworkLoc, nil, 0); - GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); - if opcode = pc_sto then - GenImplied(m_pla) - else {if op^.opcode = pc_cpi then} - GenNative(m_lda_s, direct, 1, nil, 0); - GenNative(m_sta_indl, direct, dworkLoc, nil, 0); - GenNative(m_ldy_imm, immediate, 2, nil, 0); - if opcode = pc_sto then - GenImplied(m_pla) - else {if op^.opcode = pc_cpi then} - GenNative(m_lda_s, direct, 3, nil, 0); - GenNative(m_sta_indly, direct, dworkLoc, nil, 0); - GenImplied(m_iny); - GenImplied(m_iny); - if opcode = pc_sto then - GenImplied(m_pla) - else {if op^.opcode = pc_cpi then} - GenNative(m_lda_s, direct, 5, nil, 0); - GenNative(m_sta_indly, direct, dworkLoc, nil, 0); - GenImplied(m_iny); - GenImplied(m_iny); - if opcode = pc_sto then - GenImplied(m_pla) - else {if op^.opcode = pc_cpi then} - GenNative(m_lda_s, direct, 7, nil, 0); - GenNative(m_sta_indly, direct, dworkLoc, nil, 0); - if op^.opcode = pc_cpi then - gQuad.where := onStack; end; {case cgQuad,cgUQuad} cgLong,cgULong: begin @@ -4486,55 +4589,60 @@ case optype of end; cgQuad, cgUQuad: begin - gQuad.preference := onStack; + if op^.opcode = pc_str then begin + gQuad.preference := localAddress; + gQuad.disp := disp; + end {if} + else {if op^.opcode = pc_cop then} + gQuad.preference := onStack; GenTree(op^.left); - if disp < 250 then begin - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 1, nil, 0); - GenNative(m_sta_dir, direct, disp, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 3, nil, 0); - GenNative(m_sta_dir, direct, disp+2, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 5, nil, 0); - GenNative(m_sta_dir, direct, disp+4, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 7, nil, 0); - GenNative(m_sta_dir, direct, disp+6, nil, 0); - end {else if} - else begin - GenNative(m_ldx_imm, immediate, disp, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 1, nil, 0); - GenNative(m_sta_dirX, direct, 0, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 3, nil, 0); - GenNative(m_sta_dirX, direct, 2, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 5, nil, 0); - GenNative(m_sta_dirX, direct, 4, nil, 0); - if op^.opcode = pc_str then - GenImplied(m_pla) - else {if op^.opcode = pc_cop then} - GenNative(m_lda_s, direct, 7, nil, 0); - GenNative(m_sta_dirX, direct, 6, nil, 0); - end; {else} - if op^.opcode = pc_cop then - gQuad.where := onStack; + if gQuad.where = onStack then begin + if disp < 250 then begin + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_dir, direct, disp, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_dir, direct, disp+2, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_dir, direct, disp+4, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_dir, direct, disp+6, nil, 0); + end {else if} + else begin + GenNative(m_ldx_imm, immediate, disp, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_dirX, direct, 0, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_dirX, direct, 2, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_dirX, direct, 4, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_dirX, direct, 6, nil, 0); + end; {else} + end; {if} end; otherwise: Error(cge1); @@ -5440,11 +5548,23 @@ procedure GenTree {op: icptr}; end; cgQuad,cgUQuad: begin - GenNative(m_pea, immediate, long(op^.qval.hi).msw, nil, 0); - GenNative(m_pea, immediate, long(op^.qval.hi).lsw, nil, 0); - GenNative(m_pea, immediate, long(op^.qval.lo).msw, nil, 0); - GenNative(m_pea, immediate, long(op^.qval.lo).lsw, nil, 0); - gQuad.where := onStack; + if gQuad.preference = onStack then begin + GenNative(m_pea, immediate, long(op^.qval.hi).msw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.hi).lsw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.lo).msw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.lo).lsw, nil, 0); + end {if} + else begin + GenNative(m_lda_imm, immediate, long(op^.qval.hi).msw, nil, 0); + StoreWordOfQuad(6); + GenNative(m_lda_imm, immediate, long(op^.qval.hi).lsw, nil, 0); + StoreWordOfQuad(4); + GenNative(m_lda_imm, immediate, long(op^.qval.lo).msw, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_imm, immediate, long(op^.qval.lo).lsw, nil, 0); + StoreWordOfQuad(0); + end; {else} + gQuad.where := gQuad.preference; end; otherwise: @@ -5525,25 +5645,25 @@ procedure GenTree {op: icptr}; cgQuad, cgUQuad: begin if smallMemoryModel then begin GenNative(m_lda_abs, absolute, op^.q+6, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenNative(m_lda_abs, absolute, op^.q+4, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenNative(m_lda_abs, absolute, op^.q+2, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end {if} else begin GenNative(m_lda_long, longabsolute, op^.q+6, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(6); GenNative(m_lda_long, longabsolute, op^.q+4, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(4); GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(2); GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0); - GenImplied(m_pha); + StoreWordOfQuad(0); end; {else} - gQuad.where := onStack; + gQuad.where := gQuad.preference; end; {case cgQuad,cgUQuad} otherwise: @@ -5610,14 +5730,27 @@ procedure GenTree {op: icptr}; GenImplied(m_pha); GenNative(m_lda_dirx, direct, 0, nil, 0); GenImplied(m_pha); + gQuad.where := onStack; end {if} else begin - GenNative(m_pei_dir, direct, disp+6, nil, 0); - GenNative(m_pei_dir, direct, disp+4, nil, 0); - GenNative(m_pei_dir, direct, disp+2, nil, 0); - GenNative(m_pei_dir, direct, disp, nil, 0); + if gQuad.preference = onStack then begin + GenNative(m_pei_dir, direct, disp+6, nil, 0); + GenNative(m_pei_dir, direct, disp+4, nil, 0); + GenNative(m_pei_dir, direct, disp+2, nil, 0); + GenNative(m_pei_dir, direct, disp, nil, 0); + end {if} + else begin + GenNative(m_lda_dir, direct, disp+6, nil, 0); + StoreWordOfQuad(6); + GenNative(m_lda_dir, direct, disp+4, nil, 0); + StoreWordOfQuad(4); + GenNative(m_lda_dir, direct, disp+2, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_dir, direct, disp, nil, 0); + StoreWordOfQuad(0); + end; {else} + gQuad.where := gQuad.preference; end; {else} - gQuad.where := onStack; end; cgLong, cgULong: begin From b0a61fbadffeefec78de8610c5ee0a92ea3ccca5 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 21 Feb 2021 18:37:17 -0600 Subject: [PATCH 60/68] Let functions store a long long return value directly into a variable in the caller. This optimization works when the return value is stored directly to a local variable and not used otherwise (typically only recognized when using intermediate code peephole optimization). --- Gen.pas | 69 +++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 48 insertions(+), 21 deletions(-) diff --git a/Gen.pas b/Gen.pas index 31f7be7..e03a223 100644 --- a/Gen.pas +++ b/Gen.pas @@ -5036,6 +5036,7 @@ procedure GenTree {op: icptr}; var lab1: integer; {return point} lLong: longType; {used to reserve gLong} + lQuad: quadType; {saved copy of gQuad} lArgsSize: integer; {saved copy of argsSize} extraStackSize: integer; {size of extra stuff pushed on stack} @@ -5045,12 +5046,13 @@ procedure GenTree {op: icptr}; extraStackSize := 0; {For functions returning cg(U)Quad, make space for result} - if op^.optype in [cgQuad,cgUQuad] then begin - GenImplied(m_tsc); - GenImplied(m_sec); - GenNative(m_sbc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); - end; {if} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference <> localAddress then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin @@ -5066,6 +5068,7 @@ procedure GenTree {op: icptr}; {generate parameters} {place the operands on the stack} + lQuad := gQuad; lLong := gLong; GenTree(op^.left); @@ -5073,14 +5076,22 @@ procedure GenTree {op: icptr}; gLong.preference := onStack; GenTree(op^.right); gLong := lLong; + gQuad := lQuad; {For functions returning cg(U)Quad, x = address to store result in} - if op^.optype in [cgQuad,cgUQuad] then begin - GenImplied(m_tsc); - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, argsSize+extraStackSize+4+1, nil, 0); - GenImplied(m_tax); - end; {if} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference = localAddress then begin + GenImplied(m_tdc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, gQuad.disp, nil, 0); + GenImplied(m_tax); + end {if} + else begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, argsSize+extraStackSize+4+1, nil, 0); + GenImplied(m_tax); + end; {else} {create a return label} lab1 := GenLabel; @@ -5130,7 +5141,10 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; - gQuad.where := onStack; + if gQuad.preference = localAddress then + gQuad.where := localAddress + else + gQuad.where := onStack; SaveRetValue(op^.optype); argsSize := lArgsSize; end; {GenCui} @@ -5142,6 +5156,7 @@ procedure GenTree {op: icptr}; var lLong: longType; {used to reserve gLong} + lQuad: quadType; {saved copy of gQuad} lArgsSize: integer; {saved copy of argsSize} extraStackSize: integer; {size of extra stuff pushed on stack} @@ -5151,12 +5166,13 @@ procedure GenTree {op: icptr}; extraStackSize := 0; {For functions returning cg(U)Quad, make space for result} - if op^.optype in [cgQuad,cgUQuad] then begin - GenImplied(m_tsc); - GenImplied(m_sec); - GenNative(m_sbc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); - end; {if} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference <> localAddress then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin @@ -5171,13 +5187,21 @@ procedure GenTree {op: icptr}; end; {if} {generate parameters} + lQuad := gQuad; lLong := gLong; GenTree(op^.left); gLong := lLong; + gQuad := lQuad; {For functions returning cg(U)Quad, x = address to store result in} if op^.optype in [cgQuad,cgUQuad] then - if argsSize + extraStackSize in [0,1,2] then begin + if gQuad.preference = localAddress then begin + GenImplied(m_tdc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, gQuad.disp, nil, 0); + GenImplied(m_tax); + end {if} + else if argsSize + extraStackSize in [0,1,2] then begin GenImplied(m_tsx); GenImplied(m_inx); if argsSize + extraStackSize in [1,2] then begin @@ -5225,7 +5249,10 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; - gQuad.where := onStack; + if gQuad.preference = localAddress then + gQuad.where := localAddress + else + gQuad.where := onStack; SaveRetValue(op^.optype); argsSize := lArgsSize; end; {GenCup} From 4020098dd6b3dd33f6b4f2c79cfef6abe2adf483 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 21 Feb 2021 18:43:53 -0600 Subject: [PATCH 61/68] Evaluate constant expressions with long long and floating operands. Note that we currently defer evaluation of such expressions to run time if the long long value cannot be represented exactly in a double, because statically-evaluated floating point expressions use the double format rather than the extended (long double) format used at run time. --- Expression.pas | 37 +++++++++++++++++++++---------------- Scanner.pas | 1 - 2 files changed, 21 insertions(+), 17 deletions(-) diff --git a/Expression.pas b/Expression.pas index 37d10b4..7a669e8 100644 --- a/Expression.pas +++ b/Expression.pas @@ -983,7 +983,7 @@ var end; {Pop} - function RealVal (token: tokenType): double; + function RealVal (token: tokenType): extended; { convert an operand to a real value } @@ -1004,6 +1004,10 @@ var else RealVal := token.lval; end {else if} + else if token.kind = longlongconst then + RealVal := CnvLLX(token.qval) + else if token.kind = ulonglongconst then + RealVal := CnvULLX(token.qval) else RealVal := token.rval; end; {RealVal} @@ -1434,14 +1438,24 @@ var end; {if} end; {if} - if op^.right^.token.kind in - [intconst,uintconst,longconst,ulongconst,doubleconst] then - if op^.left^.token.kind in - [intconst,uintconst,longconst,ulongconst,doubleconst] then + if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst,doubleconst] then + if op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst,doubleconst] then begin ekind := doubleconst; {evaluate a constant operation} - rop1 := RealVal(op^.left^.token); - rop2 := RealVal(op^.right^.token); + extop1 := RealVal(op^.left^.token); + rop1 := extop1; + if op^.left^.token.kind in [longlongconst,ulonglongconst] then + if rop1 <> extop1 then + if not (op^.token.kind in [barbarop,andandop]) then + goto 1; + extop1 := RealVal(op^.right^.token); + rop2 := extop1; + if op^.right^.token.kind in [longlongconst,ulonglongconst] then + if rop2 <> extop1 then + if not (op^.token.kind in [barbarop,andandop]) then + goto 1; dispose(op^.right); op^.right := nil; dispose(op^.left); @@ -1496,16 +1510,7 @@ var op^.token.class := doubleConstant; op^.token.kind := doubleConst; end; {else} - goto 1; end; {if} - - if op^.right^.token.kind in [intconst,uintconst,longconst, - ulongconst,longlongconst,ulonglongconst,doubleconst] then - if op^.left^.token.kind in [intconst,uintconst,longconst, - ulongconst,longlongconst,ulonglongconst,doubleconst] then - if not (kind in [normalExpression,autoInitializerExpression]) - then - Error(157); 1: end; diff --git a/Scanner.pas b/Scanner.pas index a727a1b..872d921 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -692,7 +692,6 @@ if list or (numErr <> 0) then begin 154: msg := @'lint: function declared _Noreturn can return or has unreachable code'; 155: msg := @'lint: non-void function may not return a value or has unreachable code'; 156: msg := @'invalid suffix on numeric constant'; - 157: msg := @'ORCA/C cannot evaluate this constant expression with long long operand(s)'; otherwise: Error(57); end; {case} writeln(msg^); From 043124db9372e0d103c21817247e700b2ee6c747 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Wed, 24 Feb 2021 19:44:28 -0600 Subject: [PATCH 62/68] Implement support for doing quad ops without loading operands on stack. This works when both operands are simple loads, such that they can be broken up into operations on their subwords in a standard format. Currently, this is implemented for bitwise binary ops, but it can also be expanded to arithmetic, etc. --- CGI.pas | 6 ++ Gen.pas | 291 +++++++++++++++++++++++++++++++++++++++++++------------- 2 files changed, 229 insertions(+), 68 deletions(-) diff --git a/CGI.pas b/CGI.pas index a3d7e26..0046898 100644 --- a/CGI.pas +++ b/CGI.pas @@ -49,10 +49,12 @@ const m_adc_dir = $65; m_adc_imm = $69; m_adc_s = $63; + m_adc_indl = $67; m_and_abs = $2D; m_and_dir = $25; m_and_imm = $29; m_and_s = $23; + m_and_indl = $27; m_asl_a = $0A; m_bcc = $90; m_bcs = $B0; @@ -71,6 +73,7 @@ const m_cmp_imm = $C9; m_cmp_long = $CF; m_cmp_s = $C3; + m_cmp_indl = $C7; m_cop = $02; m_cpx_abs = 236; m_cpx_dir = 228; @@ -86,6 +89,7 @@ const m_eor_dir = 69; m_eor_imm = 73; m_eor_s = 67; + m_eor_indl = $47; m_ina = 26; m_inc_abs = 238; m_inc_absX = $FE; @@ -122,6 +126,7 @@ const m_ora_long = 15; m_ora_longX = 31; m_ora_s = 3; + m_ora_indl = $07; m_pea = 244; m_pei_dir = 212; m_pha = 72; @@ -143,6 +148,7 @@ const m_sbc_dir = 229; m_sbc_imm = 233; m_sbc_s = 227; + m_sbc_indl = $E7; m_sec = 56; m_sep = 226; m_sta_abs = 141; diff --git a/Gen.pas b/Gen.pas index e03a223..f9274a7 100644 --- a/Gen.pas +++ b/Gen.pas @@ -238,6 +238,126 @@ else {if icode^.opcode in [pc_ldo, pc_sro] then} end; {DoOp} +procedure OpOnWordOfQuad (mop: integer; op: icptr; offset: integer); + +{ Do an operation that has addr modes equivalent to LDA on the } +{ subword at specified offset of the location specified by op. } +{ } +{ The generated code may modify X, and may set Y to offset. } +{ } +{ parameters: } +{ mop - machine opcode } +{ op - node to generate the leaf for } +{ offset - offset of the word to access (0, 2, 4, or 6) } + +var + loc: integer; {stack frame position} + val: integer; {immediate value} + +begin {OpOnWordOfQuad} +case op^.opcode of + + pc_ldo: begin + case mop of + m_lda_imm: mop := m_lda_abs; + m_cmp_imm: mop := m_cmp_abs; + m_adc_imm: mop := m_adc_abs; + m_and_imm: mop := m_and_abs; + m_ora_imm: mop := m_ora_abs; + m_sbc_imm: mop := m_sbc_abs; + m_eor_imm: mop := m_eor_abs; + otherwise: Error(cge1); + end; {case} + if smallMemoryModel then + GenNative(mop, absolute, op^.q+offset, op^.lab, 0) + else + GenNative(mop+2, longAbs, op^.q+offset, op^.lab, 0); + end; {case pc_ldo} + + pc_lod: begin + case mop of + m_lda_imm: mop := m_lda_dir; + m_cmp_imm: mop := m_cmp_dir; + m_adc_imm: mop := m_adc_dir; + m_and_imm: mop := m_and_dir; + m_ora_imm: mop := m_ora_dir; + m_sbc_imm: mop := m_sbc_dir; + m_eor_imm: mop := m_eor_dir; + otherwise: Error(cge1); + end; {case} + loc := LabelToDisp(op^.r) + op^.q + offset; + if loc < 256 then + GenNative(mop, direct, loc, nil, 0) + else begin + GenNative(m_ldx_imm, immediate, loc, nil, 0); + GenNative(mop+$10, direct, 0, nil, 0); + end; {else} + end; {case pc_lod} + + pc_ldc: begin + case offset of + 0: val := long(op^.qval.lo).lsw; + 2: val := long(op^.qval.lo).msw; + 4: val := long(op^.qval.hi).lsw; + 6: val := long(op^.qval.hi).msw; + otherwise: Error(cge1); + end; {case} + GenNative(mop, immediate, val, nil, 0); + end; {case pc_ldc} + + pc_ind: begin + case mop of + m_lda_imm: mop := m_lda_indl; + m_cmp_imm: mop := m_cmp_indl; + m_adc_imm: mop := m_adc_indl; + m_and_imm: mop := m_and_indl; + m_ora_imm: mop := m_ora_indl; + m_sbc_imm: mop := m_sbc_indl; + m_eor_imm: mop := m_eor_indl; + otherwise: Error(cge1); + end; {case} + if op^.left^.opcode = pc_lod then + loc := LabelToDisp(op^.left^.r) + op^.left^.q; + if (op^.left^.opcode <> pc_lod) or (loc > 255) then + Error(cge1); + if offset = 0 then + GenNative(mop, direct, loc, nil, 0) + else begin + GenNative(m_ldy_imm, immediate, offset, nil, 0); + GenNative(mop+$10, direct, loc, nil, 0); + end; {else} + end; {case pc_ind} + + otherwise: + Error(cge1); + end; {case} +end; {OpOnWordOfQuad} + + +function SimpleQuadLoad(op: icptr): boolean; + +{ Is op a simple load operation on a cg(U)Quad, which can be } +{ broken up into word operations handled by OpOnWordOfQuad? } +{ } +{ parameters: } +{ op - node to check } + +begin {SimpleQuadLoad} +case op^.opcode of + pc_ldo,pc_lod,pc_ldc: + SimpleQuadLoad := true; + + pc_ind: + SimpleQuadLoad := + (op^.left^.opcode = pc_lod) + and (LabelToDisp(op^.left^.r) + op^.left^.q < 256); + + otherwise: + SimpleQuadLoad := false; + end; {case} +end; {SimpleQuadLoad} + + procedure StoreWordOfQuad(offset: integer); { Store one word of a quad value to the location specified by } @@ -4896,91 +5016,126 @@ procedure GenTree {op: icptr}; { generate one of: pc_bqr, pc_bqx, pc_baq, pc_mpq, pc_umq, } { pc_dvq, pc_udq, pc_mdq, pc_uqm } - procedure GenOp (ops: integer); + procedure GenBitwiseOp; { generate a 64-bit binary bitwise operation } { } { parameters: } { ops - stack version of operation } - begin {GenOp} - GenImplied(m_pla); - GenNative(ops, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(ops, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(ops, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(ops, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - end; {GenOp} + var + mop: integer; {machine opcode} + + begin {GenBitwiseOp} + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin + case op^.opcode of + pc_bqr: mop := m_ora_imm; + pc_bqx: mop := m_eor_imm; + pc_baq: mop := m_and_imm; + end; {case} + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(mop, op^.right, 6); + StoreWordOfQuad(6); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(mop, op^.right, 4); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(mop, op^.right, 2); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(mop, op^.right, 0); + StoreWordOfQuad(0); + gQuad.where := gQuad.preference; + end {if} + else begin + case op^.opcode of + pc_bqr: mop := m_ora_s; + pc_bqx: mop := m_eor_s; + pc_baq: mop := m_and_s; + end; {case} + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end; {GenBitwiseOp} begin {GenBinQuad} - gQuad.preference := onStack; - GenTree(op^.left); - gQuad.preference := onStack; - GenTree(op^.right); - case op^.opcode of - pc_bqr: GenOp(m_ora_s); - pc_bqx: GenOp(m_eor_s); - pc_baq: GenOp(m_and_s); + if op^.opcode in [pc_bqr,pc_bqx,pc_baq] then + GenBitwiseOp + else begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + case op^.opcode of + pc_mpq: GenCall(79); - pc_mpq: GenCall(79); + pc_umq: GenCall(80); - pc_umq: GenCall(80); + pc_dvq: begin + GenCall(81); {do division} + GenImplied(m_pla); {get quotient, discarding remainder} + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + end; - pc_dvq: begin - GenCall(81); {do division} - GenImplied(m_pla); {get quotient, discarding remainder} - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sta_s, direct, 7, nil, 0); - end; - - pc_udq: begin - GenCall(82); {do division} - GenImplied(m_pla); {get quotient, discarding remainder} - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sta_s, direct, 7, nil, 0); - end; + pc_udq: begin + GenCall(82); {do division} + GenImplied(m_pla); {get quotient, discarding remainder} + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + end; - pc_mdq: begin - GenCall(81); {do division} - GenImplied(m_tsc); {discard quotient, leaving remainder} - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); - end; + pc_mdq: begin + GenCall(81); {do division} + GenImplied(m_tsc); {discard quotient, leaving remainder} + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; - pc_uqm: begin - GenCall(82); {do division} - GenImplied(m_tsc); {discard quotient, leaving remainder} - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); - end; + pc_uqm: begin + GenCall(82); {do division} + GenImplied(m_tsc); {discard quotient, leaving remainder} + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; - pc_slq: GenCall(85); + pc_slq: GenCall(85); - pc_sqr: GenCall(86); + pc_sqr: GenCall(86); - pc_wsr: GenCall(87); + pc_wsr: GenCall(87); - otherwise: Error(cge1); - end; {case} - gQuad.where := onStack; + otherwise: Error(cge1); + end; {case} + gQuad.where := onStack; + end; {else} end; {GenBinQuad} From 0b56689626f2c7337a66ed019f416d124525e4dd Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 25 Feb 2021 18:26:26 -0600 Subject: [PATCH 63/68] Do quad add/subtract without loading operands on stack. As with the previous support for bitwise ops, this applies if the operands are simple quad loads. --- Gen.pas | 125 +++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 93 insertions(+), 32 deletions(-) diff --git a/Gen.pas b/Gen.pas index f9274a7..b7b1390 100644 --- a/Gen.pas +++ b/Gen.pas @@ -47,6 +47,7 @@ const globalLabel = 16; constant = 32; nowhere = 64; + inStackLoc = 128; {stack frame locations} {---------------------} @@ -403,6 +404,9 @@ case gQuad.preference of end; {else} end; + inStackLoc: + GenNative(m_sta_s, direct, gQuad.disp+offset, nil, 0); + onStack: GenImplied(m_pha); @@ -876,41 +880,98 @@ procedure GenAdqSbq (op: icptr); { op - pc_adq or pc_sbq operation } begin {GenAdqSbq} -gQuad.preference := onStack; -GenTree(op^.right); -gQuad.preference := onStack; -GenTree(op^.left); if op^.opcode = pc_adq then begin - GenImplied(m_clc); - GenImplied(m_pla); - GenNative(m_adc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_adc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_adc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_adc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - end {else} + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin + gQuad.where := gQuad.preference; + if gQuad.preference = onStack then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + gQuad.preference := inStackLoc; + gQuad.disp := 1; + end; {if} + GenImplied(m_clc); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_adc_imm, op^.right, 0); + StoreWordOfQuad(0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_adc_imm, op^.right, 2); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_adc_imm, op^.right, 4); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_adc_imm, op^.right, 6); + StoreWordOfQuad(6); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.right); + gQuad.preference := onStack; + GenTree(op^.left); + GenImplied(m_clc); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end {if} else {if op^.opcode = pc_sbq then} begin - GenImplied(m_sec); - GenImplied(m_pla); - GenNative(m_sbc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sbc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sbc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); - GenImplied(m_pla); - GenNative(m_sbc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin + gQuad.where := gQuad.preference; + if gQuad.preference = onStack then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + gQuad.preference := inStackLoc; + gQuad.disp := 1; + end; {if} + GenImplied(m_sec); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_sbc_imm, op^.right, 0); + StoreWordOfQuad(0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_sbc_imm, op^.right, 2); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_sbc_imm, op^.right, 4); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_sbc_imm, op^.right, 6); + StoreWordOfQuad(6); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.right); + gQuad.preference := onStack; + GenTree(op^.left); + GenImplied(m_sec); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} end; {else} -gQuad.where := onStack; end; {GenAdqSbq} From f1c19d2940880ff6f0ad28eeb43aa6f90590bfcf Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 25 Feb 2021 19:28:36 -0600 Subject: [PATCH 64/68] Do unary quad ops without loading operand on stack. --- Gen.pas | 106 ++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 77 insertions(+), 29 deletions(-) diff --git a/Gen.pas b/Gen.pas index b7b1390..d820c16 100644 --- a/Gen.pas +++ b/Gen.pas @@ -4869,43 +4869,89 @@ procedure GenUnaryQuad (op: icptr); { generate a pc_bnq or pc_ngq } begin {GenUnaryQuad} -gQuad.preference := onStack; -GenTree(op^.left); case op^.opcode of {do the operation} pc_bnq: begin - GenNative(m_lda_s, direct, 1, nil, 0); - GenNative(m_eor_imm, immediate, $FFFF, nil, 0); - GenNative(m_sta_s, direct, 1, nil, 0); - GenNative(m_lda_s, direct, 3, nil, 0); - GenNative(m_eor_imm, immediate, $FFFF, nil, 0); - GenNative(m_sta_s, direct, 3, nil, 0); - GenNative(m_lda_s, direct, 5, nil, 0); - GenNative(m_eor_imm, immediate, $FFFF, nil, 0); - GenNative(m_sta_s, direct, 5, nil, 0); - GenNative(m_lda_s, direct, 7, nil, 0); - GenNative(m_eor_imm, immediate, $FFFF, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); + if SimpleQuadLoad(op^.left) then begin + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(6); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(0); + gQuad.where := gQuad.preference; + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.left); + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 1, nil, 0); + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 3, nil, 0); + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 5, nil, 0); + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} end; {case pc_bnq} pc_ngq: begin - GenImplied(m_sec); - GenNative(m_ldy_imm, immediate, 0, nil, 0); - GenImplied(m_tya); - GenNative(m_sbc_s, direct, 1, nil, 0); - GenNative(m_sta_s, direct, 1, nil, 0); - GenImplied(m_tya); - GenNative(m_sbc_s, direct, 3, nil, 0); - GenNative(m_sta_s, direct, 3, nil, 0); - GenImplied(m_tya); - GenNative(m_sbc_s, direct, 5, nil, 0); - GenNative(m_sta_s, direct, 5, nil, 0); - GenImplied(m_tya); - GenNative(m_sbc_s, direct, 7, nil, 0); - GenNative(m_sta_s, direct, 7, nil, 0); + if SimpleQuadLoad(op^.left) then begin + gQuad.where := gQuad.preference; + if gQuad.preference = onStack then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + gQuad.preference := inStackLoc; + gQuad.disp := 1; + end; {if} + GenImplied(m_sec); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 0); + StoreWordOfQuad(0); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 2); + StoreWordOfQuad(2); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 4); + StoreWordOfQuad(4); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 6); + StoreWordOfQuad(6); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.left); + GenImplied(m_sec); + GenNative(m_ldy_imm, immediate, 0, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 1, nil, 0); + GenNative(m_sta_s, direct, 1, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 3, nil, 0); + GenNative(m_sta_s, direct, 3, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 5, nil, 0); + GenNative(m_sta_s, direct, 5, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} end; {case pc_ngq} end; {case} -gQuad.where := onStack; end; {GenUnaryQuad} @@ -7006,6 +7052,8 @@ end; {GenTree} {---------------------------------------------------------------} +{$segment 'gen2'} + procedure Gen {blk: blockPtr}; { Generates native code for a list of blocks } From c5c401d229b65d351a6ac438351528f5f135f182 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 25 Feb 2021 20:03:13 -0600 Subject: [PATCH 65/68] Do quad equality comparisons without loading operands on stack. --- Gen.pas | 77 +++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 48 insertions(+), 29 deletions(-) diff --git a/Gen.pas b/Gen.pas index d820c16..0d47c10 100644 --- a/Gen.pas +++ b/Gen.pas @@ -2263,38 +2263,57 @@ else end; {case optype of cgReal..cgExtended} cgQuad,cgUQuad: begin - gQuad.preference := onStack; - GenTree(op^.left); - gQuad.preference := onStack; - GenTree(op^.right); + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) + and not volatile then begin + lab1 := GenLabel; + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_eor_imm, op^.right, 0); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_eor_imm, op^.right, 2); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_eor_imm, op^.right, 4); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_eor_imm, op^.right, 6); + GenLab(lab1); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); - lab1 := GenLabel; - lab2 := GenLabel; - GenImplied(m_pla); - GenImplied(m_plx); - GenImplied(m_ply); - GenNative(m_eor_s, direct, 3, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); - GenImplied(m_txa); - GenNative(m_eor_s, direct, 5, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); - GenImplied(m_tya); - GenNative(m_eor_s, direct, 7, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); - GenImplied(m_pla); - GenNative(m_eor_s, direct, 7, nil, 0); - GenNative(m_bra, relative, lab2, nil, 0); - GenLab(lab1); - GenImplied(m_plx); - GenLab(lab2); - GenImplied(m_tax); + lab1 := GenLabel; + lab2 := GenLabel; + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenNative(m_eor_s, direct, 3, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_txa); + GenNative(m_eor_s, direct, 5, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_tya); + GenNative(m_eor_s, direct, 7, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_pla); + GenNative(m_eor_s, direct, 7, nil, 0); + GenNative(m_bra, relative, lab2, nil, 0); + GenLab(lab1); + GenImplied(m_plx); + GenLab(lab2); + GenImplied(m_tax); - GenImplied(m_tsc); - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, 8, nil, 0); - GenImplied(m_tcs); + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + + GenImplied(m_txa); + end; {else} - GenImplied(m_txa); if opcode in [pc_fjp,pc_tjp] then begin lab3 := GenLabel; if opcode = pc_fjp then From 5c92a8a0d3d090f66cc3b5c1fabfe4fdd0919596 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 25 Feb 2021 20:18:59 -0600 Subject: [PATCH 66/68] Do unsigned quad inequalities without loading operands on stack. --- Gen.pas | 85 +++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 65 insertions(+), 20 deletions(-) diff --git a/Gen.pas b/Gen.pas index 0d47c10..caaf6ad 100644 --- a/Gen.pas +++ b/Gen.pas @@ -359,6 +359,29 @@ case op^.opcode of end; {SimpleQuadLoad} +function SimplestQuadLoad(op: icptr): boolean; + +{ Is op a simple load operation on a cg(U)Quad, which can be } +{ broken up into word operations handled by OpOnWordOfQuad } +{ and for which those operations will not modify X or Y. } +{ } +{ parameters: } +{ op - node to check } + +begin {SimplestQuadLoad} +case op^.opcode of + pc_ldo,pc_ldc: + SimplestQuadLoad := true; + + pc_lod: + SimplestQuadLoad := LabelToDisp(op^.r) + op^.q < 250; + + pc_ind,otherwise: + SimplestQuadLoad := false; + end; {case} +end; {SimplestQuadLoad} + + procedure StoreWordOfQuad(offset: integer); { Store one word of a quad value to the location specified by } @@ -992,6 +1015,7 @@ var i: integer; {loop variable} lab1,lab2,lab3,lab4: integer; {label numbers} num: integer; {constant to compare to} + simple: boolean; {is this a simple case?} procedure Switch; @@ -1447,28 +1471,47 @@ else end; {case optype of cgQuad} cgUQuad: begin - gQuad.preference := onStack; - GenTree(op^.left); - gQuad.preference := onStack; - GenTree(op^.right); + simple := + SimplestQuadLoad(op^.left) and SimplestQuadLoad(op^.right) + and not volatile; + if not simple then begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + end; {if} if op^.opcode = pc_geq then GenNative(m_ldx_imm, immediate, 1, nil, 0) else {if op^.opcode = pc_grt then} GenNative(m_ldx_imm, immediate, 0, nil, 0); lab1 := GenLabel; lab2 := GenLabel; - GenNative(m_lda_s, direct, 15, nil, 0); - GenNative(m_cmp_s, direct, 7, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); - GenNative(m_lda_s, direct, 13, nil, 0); - GenNative(m_cmp_s, direct, 5, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); - GenNative(m_lda_s, direct, 11, nil, 0); - GenNative(m_cmp_s, direct, 3, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); - GenNative(m_lda_s, direct, 9, nil, 0); - GenNative(m_cmp_s, direct, 1, nil, 0); - GenNative(m_bne, relative, lab1, nil, 0); + if simple then begin + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_cmp_imm, op^.right, 6); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_cmp_imm, op^.right, 4); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_cmp_imm, op^.right, 2); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_cmp_imm, op^.right, 0); + end {if} + else begin + GenNative(m_lda_s, direct, 15, nil, 0); + GenNative(m_cmp_s, direct, 7, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 13, nil, 0); + GenNative(m_cmp_s, direct, 5, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 11, nil, 0); + GenNative(m_cmp_s, direct, 3, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 9, nil, 0); + GenNative(m_cmp_s, direct, 1, nil, 0); + end; {else} GenLab(lab1); if op^.opcode = pc_geq then begin GenNative(m_bcs, relative, lab2, nil, 0); @@ -1480,10 +1523,12 @@ else GenImplied(m_inx); end; {else} GenLab(lab2); - GenImplied(m_tsc); - GenImplied(m_clc); - GenNative(m_adc_imm, immediate, 16, nil, 0); - GenImplied(m_tcs); + if not simple then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 16, nil, 0); + GenImplied(m_tcs); + end; {if} GenImplied(m_txa); if rOpcode = pc_fjp then begin lab3 := GenLabel; From 36d31ab37cd6c8ee88be01e187a77ec160002c42 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 25 Feb 2021 21:40:32 -0600 Subject: [PATCH 67/68] Optimize quad == 0 comparisons. --- Gen.pas | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/Gen.pas b/Gen.pas index caaf6ad..ab572ef 100644 --- a/Gen.pas +++ b/Gen.pas @@ -2308,7 +2308,18 @@ else end; {case optype of cgReal..cgExtended} cgQuad,cgUQuad: begin - if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) + if SimpleQuadLoad(op^.left) and (op^.right^.opcode = pc_ldc) + and (op^.right^.qval.hi = 0) and (op^.right^.qval.lo = 0) then begin + lab1 := GenLabel; + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + if not volatile then + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_ora_imm, op^.left, 2); + OpOnWordOfQuad(m_ora_imm, op^.left, 4); + OpOnWordOfQuad(m_ora_imm, op^.left, 6); + GenLab(lab1); + end {if} + else if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) and not volatile then begin lab1 := GenLabel; OpOnWordOfQuad(m_lda_imm, op^.left, 0); @@ -5019,6 +5030,8 @@ case op^.opcode of {do the operation} end; {GenUnaryQuad} +{$segment 'gen2'} + procedure GenTree {op: icptr}; { generate code for op and its children } @@ -7116,8 +7129,6 @@ end; {GenTree} {---------------------------------------------------------------} -{$segment 'gen2'} - procedure Gen {blk: blockPtr}; { Generates native code for a list of blocks } From 21f8876f503def4ec041f00bea10e6e84919d3fb Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Thu, 25 Feb 2021 21:42:54 -0600 Subject: [PATCH 68/68] In PP expressions, make sure identifiers turn into 0LL. --- Expression.pas | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Expression.pas b/Expression.pas index 7a669e8..0140c62 100644 --- a/Expression.pas +++ b/Expression.pas @@ -898,8 +898,9 @@ var {in the preprocessor, all identifiers (post macro replacement) become 0} if kind = preprocessorExpression then begin - stack^.token.kind := longconst; - stack^.token.lval := 0; + stack^.token.class := longlongConstant; + stack^.token.kind := longlongconst; + stack^.token.qval := longlong0; end {if} {if the id is not declared, create a function returning integer}