Commit | Line | Data |
---|---|---|
196ba1fc PH |
1 | /* hp2100_cpu3.c: HP 2100/1000 FFP/DBI instructions\r |
2 | \r | |
3 | Copyright (c) 2005-2008, J. David Bryan\r | |
4 | \r | |
5 | Permission is hereby granted, free of charge, to any person obtaining a\r | |
6 | copy of this software and associated documentation files (the "Software"),\r | |
7 | to deal in the Software without restriction, including without limitation\r | |
8 | the rights to use, copy, modify, merge, publish, distribute, sublicense,\r | |
9 | and/or sell copies of the Software, and to permit persons to whom the\r | |
10 | Software is furnished to do so, subject to the following conditions:\r | |
11 | \r | |
12 | The above copyright notice and this permission notice shall be included in\r | |
13 | all copies or substantial portions of the Software.\r | |
14 | \r | |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR\r | |
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,\r | |
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL\r | |
18 | THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER\r | |
19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\r | |
20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\r | |
21 | \r | |
22 | Except as contained in this notice, the name of the author shall not be\r | |
23 | used in advertising or otherwise to promote the sale, use or other dealings\r | |
24 | in this Software without prior written authorization from the author.\r | |
25 | \r | |
26 | CPU3 Fast FORTRAN and Double Integer instructions\r | |
27 | \r | |
28 | 27-Feb-08 JDB Added DBI self-test instruction\r | |
29 | 23-Oct-07 JDB Fixed unsigned-divide bug in .DDI\r | |
30 | 17-Oct-07 JDB Fixed unsigned-multiply bug in .DMP\r | |
31 | 16-Oct-06 JDB Calls FPP for extended-precision math\r | |
32 | 12-Oct-06 JDB Altered DBLE, DDINT for F-Series FFP compatibility\r | |
33 | 26-Sep-06 JDB Moved from hp2100_cpu1.c to simplify extensions\r | |
34 | 09-Aug-06 JDB Added double-integer instruction set\r | |
35 | 18-Feb-05 JDB Add 2100/21MX Fast FORTRAN Processor instructions\r | |
36 | \r | |
37 | Primary references:\r | |
38 | - HP 1000 M/E/F-Series Computers Technical Reference Handbook\r | |
39 | (5955-0282, Mar-1980)\r | |
40 | - HP 1000 M/E/F-Series Computers Engineering and Reference Documentation\r | |
41 | (92851-90001, Mar-1981)\r | |
42 | - Macro/1000 Reference Manual (92059-90001, Dec-1992)\r | |
43 | \r | |
44 | Additional references are listed with the associated firmware\r | |
45 | implementations, as are the HP option model numbers pertaining to the\r | |
46 | applicable CPUs.\r | |
47 | */\r | |
48 | \r | |
49 | #include "hp2100_defs.h"\r | |
50 | #include "hp2100_cpu.h"\r | |
51 | #include "hp2100_cpu1.h"\r | |
52 | \r | |
53 | #if defined (HAVE_INT64) /* int64 support available */\r | |
54 | #include "hp2100_fp1.h"\r | |
55 | #else /* int64 support unavailable */\r | |
56 | #include "hp2100_fp.h"\r | |
57 | #endif /* end of int64 support */\r | |
58 | \r | |
59 | \r | |
60 | t_stat cpu_ffp (uint32 IR, uint32 intrq); /* Fast FORTRAN Processor */\r | |
61 | t_stat cpu_dbi (uint32 IR, uint32 intrq); /* Double-Integer instructions */\r | |
62 | \r | |
63 | \r | |
64 | /* Fast FORTRAN Processor.\r | |
65 | \r | |
66 | The Fast FORTRAN Processor (FFP) is a set of FORTRAN language accelerators\r | |
67 | and extended-precision (three-word) floating point routines. Although the\r | |
68 | FFP is an option for the 2100 and later CPUs, each implements the FFP in a\r | |
69 | slightly different form.\r | |
70 | \r | |
71 | Option implementation by CPU was as follows:\r | |
72 | \r | |
73 | 2114 2115 2116 2100 1000-M 1000-E 1000-F\r | |
74 | ------ ------ ------ ------ ------ ------ ------\r | |
75 | N/A N/A N/A 12907A 12977B 13306B std\r | |
76 | \r | |
77 | The instruction codes are mapped to routines as follows:\r | |
78 | \r | |
79 | Instr. 2100 1000-M 1000-E 1000-F Instr. 2100 1000-M 1000-E 1000-F\r | |
80 | ------ ------ ------ ------ ------ ------ ------ ------ ------ ------\r | |
81 | 105200 -- [nop] [nop] [test] 105220 .XFER .XFER .XFER .XFER\r | |
82 | 105201 DBLE DBLE DBLE DBLE 105221 .GOTO .GOTO .GOTO .GOTO\r | |
83 | 105202 SNGL SNGL SNGL SNGL 105222 ..MAP ..MAP ..MAP ..MAP\r | |
84 | 105203 .XMPY .XMPY .XMPY .DNG 105223 .ENTR .ENTR .ENTR .ENTR\r | |
85 | 105204 .XDIV .XDIV .XDIV .DCO 105224 .ENTP .ENTP .ENTP .ENTP\r | |
86 | 105205 .DFER .DFER .DFER .DFER 105225 -- .PWR2 .PWR2 .PWR2\r | |
87 | 105206 -- .XPAK .XPAK .XPAK 105226 -- .FLUN .FLUN .FLUN\r | |
88 | 105207 -- XADD XADD .BLE 105227 $SETP $SETP $SETP $SETP\r | |
89 | \r | |
90 | 105210 -- XSUB XSUB .DIN 105230 -- .PACK .PACK .PACK\r | |
91 | 105211 -- XMPY XMPY .DDE 105231 -- -- .CFER .CFER\r | |
92 | 105212 -- XDIV XDIV .DIS 105232 -- -- -- ..FCM\r | |
93 | 105213 .XADD .XADD .XADD .DDS 105233 -- -- -- ..TCM\r | |
94 | 105214 .XSUB .XSUB .XSUB .NGL 105234 -- -- -- --\r | |
95 | 105215 -- .XCOM .XCOM .XCOM 105235 -- -- -- --\r | |
96 | 105216 -- ..DCM ..DCM ..DCM 105236 -- -- -- --\r | |
97 | 105217 -- DDINT DDINT DDINT 105237 -- -- -- --\r | |
98 | \r | |
99 | The F-Series maps different instructions to several of the standard FFP\r | |
100 | opcodes. We first look for these and dispatch them appropriately before\r | |
101 | falling into the handler for the common instructions.\r | |
102 | \r | |
103 | The math functions use the F-Series FPP for implementation. The FPP requires\r | |
104 | that the host compiler support 64-bit integers. Therefore, if 64-bit\r | |
105 | integers are not available, the math instructions of the FFP are disabled.\r | |
106 | We allow this partial implementation as an aid in running systems generated\r | |
107 | for the FFP. Most system programs did not use the math instructions, but\r | |
108 | almost all use .ENTR. Supporting the latter even on systems that do not\r | |
109 | support the former still allows such systems to boot.\r | |
110 | \r | |
111 | Notes:\r | |
112 | \r | |
113 | 1. The "$SETP" instruction is sometimes listed as ".SETP" in the\r | |
114 | documentation.\r | |
115 | \r | |
116 | 2. Extended-precision arithmetic routines (e.g., .XMPY) exist on the\r | |
117 | 1000-F, but they are assigned instruction codes in the single-precision\r | |
118 | floating-point module range. They are replaced by several double\r | |
119 | integer instructions, which we dispatch to the double integer handler.\r | |
120 | \r | |
121 | 3. The software implementation of ..MAP supports 1-, 2-, or 3-dimensional\r | |
122 | arrays, designated by setting A = -1, 0, and +1, respectively. The\r | |
123 | firmware implementation supports only 2- and 3-dimensional access.\r | |
124 | \r | |
125 | 4. The documentation for ..MAP for the 2100 FFP shows A = 0 or -1 for two\r | |
126 | or three dimensions, respectively, but the 1000 FFP shows A = 0 or +1.\r | |
127 | The firmware actually only checks the LSB of A.\r | |
128 | \r | |
129 | 5. The .DFER and .XFER implementations for the 2100 FFP return X+4 and Y+4\r | |
130 | in the A and B registers, whereas the 1000 FFP returns X+3 and Y+3.\r | |
131 | \r | |
132 | 6. The .XFER implementation for the 2100 FFP returns to P+2, whereas the\r | |
133 | 1000 implementation returns to P+1.\r | |
134 | \r | |
135 | 7. The firmware implementations of DBLE, .BLE, and DDINT clear the overflow\r | |
136 | flag. The software implementations do not change overflow.\r | |
137 | \r | |
138 | 8. The M/E-Series FFP arithmetic instructions (.XADD, etc.) return negative\r | |
139 | infinity on negative overflow and positive infinity on positive\r | |
140 | overflow. The equivalent F-Series instructions return positive infinity\r | |
141 | on both.\r | |
142 | \r | |
143 | Additional references:\r | |
144 | - DOS/RTE Relocatable Library Reference Manual (24998-90001, Oct-1981)\r | |
145 | - Implementing the HP 2100 Fast FORTRAN Processor (12907-90010, Nov-1974)\r | |
146 | */\r | |
147 | \r | |
148 | static const OP_PAT op_ffp_f[32] = { /* patterns for F-Series only */\r | |
149 | OP_N, OP_AAF, OP_AX, OP_N, /* [tst] DBLE SNGL .DNG */\r | |
150 | OP_N, OP_AA, OP_A, OP_AAF, /* .DCO .DFER .XPAK .BLE */\r | |
151 | OP_N, OP_N, OP_N, OP_N, /* .DIN .DDE .DIS .DDS */\r | |
152 | OP_AT, OP_A, OP_A, OP_AAX, /* .NGL .XCOM ..DCM DDINT */\r | |
153 | OP_N, OP_AK, OP_KKKK, OP_A, /* .XFER .GOTO ..MAP .ENTR */\r | |
154 | OP_A, OP_RK, OP_R, OP_K, /* .ENTP .PWR2 .FLUN $SETP */\r | |
155 | OP_RC, OP_AA, OP_R, OP_A, /* .PACK .CFER ..FCM ..TCM */\r | |
156 | OP_N, OP_N, OP_N, OP_N /* --- --- --- --- */\r | |
157 | };\r | |
158 | \r | |
159 | static const OP_PAT op_ffp_e[32] = { /* patterns for 2100/M/E-Series */\r | |
160 | OP_N, OP_AAF, OP_AX, OP_AXX, /* [nop] DBLE SNGL .XMPY */\r | |
161 | OP_AXX, OP_AA, OP_A, OP_AAXX, /* .XDIV .DFER .XPAK XADD */\r | |
162 | OP_AAXX, OP_AAXX, OP_AAXX, OP_AXX, /* XSUB XMPY XDIV .XADD */\r | |
163 | OP_AXX, OP_A, OP_A, OP_AAX, /* .XSUB .XCOM ..DCM DDINT */\r | |
164 | OP_N, OP_AK, OP_KKKK, OP_A, /* .XFER .GOTO ..MAP .ENTR */\r | |
165 | OP_A, OP_RK, OP_R, OP_K, /* .ENTP .PWR2 .FLUN $SETP */\r | |
166 | OP_RC, OP_AA, OP_N, OP_N, /* .PACK .CFER --- --- */\r | |
167 | OP_N, OP_N, OP_N, OP_N /* --- --- --- --- */\r | |
168 | };\r | |
169 | \r | |
170 | t_stat cpu_ffp (uint32 IR, uint32 intrq)\r | |
171 | {\r | |
172 | OP fpop;\r | |
173 | OPS op, op2;\r | |
174 | uint32 entry;\r | |
175 | uint32 j, sa, sb, sc, da, dc, ra, MA;\r | |
176 | int32 expon;\r | |
177 | t_stat reason = SCPE_OK;\r | |
178 | \r | |
179 | #if defined (HAVE_INT64) /* int64 support available */\r | |
180 | \r | |
181 | int32 i;\r | |
182 | \r | |
183 | #endif /* end of int64 support */\r | |
184 | \r | |
185 | if ((cpu_unit.flags & UNIT_FFP) == 0) /* FFP option installed? */\r | |
186 | return stop_inst;\r | |
187 | \r | |
188 | entry = IR & 037; /* mask to entry point */\r | |
189 | \r | |
190 | if (UNIT_CPU_MODEL != UNIT_1000_F) { /* 2100/M/E-Series? */\r | |
191 | if (op_ffp_e[entry] != OP_N)\r | |
192 | if (reason = cpu_ops (op_ffp_e[entry], op, intrq)) /* get instruction operands */\r | |
193 | return reason;\r | |
194 | }\r | |
195 | \r | |
196 | #if defined (HAVE_INT64) /* int64 support available */\r | |
197 | \r | |
198 | else { /* F-Series */\r | |
199 | if (op_ffp_f[entry] != OP_N)\r | |
200 | if (reason = cpu_ops (op_ffp_f[entry], op, intrq)) /* get instruction operands */\r | |
201 | return reason;\r | |
202 | \r | |
203 | switch (entry) { /* decode IR<4:0> */\r | |
204 | \r | |
205 | case 000: /* [tst] 105200 (OP_N) */\r | |
206 | XR = 4; /* firmware revision */\r | |
207 | SR = 0102077; /* test passed code */\r | |
208 | AR = 0; /* test clears A/B */\r | |
209 | BR = 0;\r | |
210 | PC = (PC + 1) & VAMASK; /* P+2 return for firmware w/DBI */\r | |
211 | return reason;\r | |
212 | \r | |
213 | case 003: /* .DNG 105203 (OP_N) */\r | |
214 | return cpu_dbi (0105323, intrq); /* remap to double int handler */\r | |
215 | \r | |
216 | case 004: /* .DCO 105204 (OP_N) */\r | |
217 | return cpu_dbi (0105324, intrq); /* remap to double int handler */\r | |
218 | \r | |
219 | case 007: /* .BLE 105207 (OP_AAF) */\r | |
220 | O = fp_cvt (&op[2], fp_f, fp_t); /* convert value and clear overflow */\r | |
221 | WriteOp (op[1].word, op[2], fp_t); /* write double-precision value */\r | |
222 | return reason;\r | |
223 | \r | |
224 | case 010: /* .DIN 105210 (OP_N) */\r | |
225 | return cpu_dbi (0105330, intrq); /* remap to double int handler */\r | |
226 | \r | |
227 | case 011: /* .DDE 105211 (OP_N) */\r | |
228 | return cpu_dbi (0105331, intrq); /* remap to double int handler */\r | |
229 | \r | |
230 | case 012: /* .DIS 105212 (OP_N) */\r | |
231 | return cpu_dbi (0105332, intrq); /* remap to double int handler */\r | |
232 | \r | |
233 | case 013: /* .DDS 105213 (OP_N) */\r | |
234 | return cpu_dbi (0105333, intrq); /* remap to double int handler */\r | |
235 | \r | |
236 | case 014: /* .NGL 105214 (OP_AT) */\r | |
237 | O = fp_cvt (&op[1], fp_t, fp_f); /* convert value */\r | |
238 | AR = op[1].fpk[0]; /* move MSB to A */\r | |
239 | BR = op[1].fpk[1]; /* move LSB to B */\r | |
240 | return reason;\r | |
241 | \r | |
242 | case 032: /* ..FCM 105232 (OP_R) */\r | |
243 | O = fp_pcom (&op[0], fp_f); /* complement value */\r | |
244 | AR = op[0].fpk[0]; /* return result */\r | |
245 | BR = op[0].fpk[1]; /* to A/B registers */\r | |
246 | return reason;\r | |
247 | \r | |
248 | case 033: /* ..TCM 105233 (OP_A) */\r | |
249 | fpop = ReadOp (op[0].word, fp_t); /* read 4-word value */\r | |
250 | O = fp_pcom (&fpop, fp_t); /* complement it */\r | |
251 | WriteOp (op[0].word, fpop, fp_t); /* write 4-word value */\r | |
252 | return reason;\r | |
253 | } /* fall thru if not special to F */\r | |
254 | }\r | |
255 | \r | |
256 | #endif /* end of int64 support */\r | |
257 | \r | |
258 | switch (entry) { /* decode IR<4:0> */\r | |
259 | \r | |
260 | /* FFP module 1 */\r | |
261 | \r | |
262 | case 000: /* [nop] 105200 (OP_N) */\r | |
263 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 M/E-series */\r | |
264 | return stop_inst; /* trap if not */\r | |
265 | break;\r | |
266 | \r | |
267 | #if defined (HAVE_INT64) /* int64 support available */\r | |
268 | \r | |
269 | case 001: /* DBLE 105201 (OP_AAF) */\r | |
270 | O = fp_cvt (&op[2], fp_f, fp_x); /* convert value and clear overflow */\r | |
271 | WriteOp (op[1].word, op[2], fp_x); /* write extended-precision value */\r | |
272 | break;\r | |
273 | \r | |
274 | case 002: /* SNGL 105202 (OP_AX) */\r | |
275 | O = fp_cvt (&op[1], fp_x, fp_f); /* convert value */\r | |
276 | AR = op[1].fpk[0]; /* move MSB to A */\r | |
277 | BR = op[1].fpk[1]; /* move LSB to B */\r | |
278 | break;\r | |
279 | \r | |
280 | case 003: /* .XMPY 105203 (OP_AXX) */\r | |
281 | i = 0; /* params start at op[0] */\r | |
282 | goto XMPY; /* process as XMPY */\r | |
283 | \r | |
284 | case 004: /* .XDIV 105204 (OP_AXX) */\r | |
285 | i = 0; /* params start at op[0] */\r | |
286 | goto XDIV; /* process as XDIV */\r | |
287 | \r | |
288 | #endif /* end of int64 support */\r | |
289 | \r | |
290 | case 005: /* .DFER 105205 (OP_AA) */\r | |
291 | BR = op[0].word; /* get destination address */\r | |
292 | AR = op[1].word; /* get source address */\r | |
293 | goto XFER; /* do transfer */\r | |
294 | \r | |
295 | #if defined (HAVE_INT64) /* int64 support available */\r | |
296 | \r | |
297 | case 006: /* .XPAK 105206 (OP_A) */\r | |
298 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
299 | return stop_inst; /* trap if not */\r | |
300 | \r | |
301 | if (intrq) { /* interrupt pending? */\r | |
302 | PC = err_PC; /* restart instruction */\r | |
303 | break;\r | |
304 | }\r | |
305 | \r | |
306 | fpop = ReadOp (op[0].word, fp_x); /* read unpacked */\r | |
307 | O = fp_nrpack (&fpop, fpop, (int16) AR, fp_x); /* nrm/rnd/pack mantissa, exponent */\r | |
308 | WriteOp (op[0].word, fpop, fp_x); /* write result */\r | |
309 | break;\r | |
310 | \r | |
311 | case 007: /* XADD 105207 (OP_AAXX) */\r | |
312 | i = 1; /* params start at op[1] */\r | |
313 | XADD: /* enter here from .XADD */\r | |
314 | if (intrq) { /* interrupt pending? */\r | |
315 | PC = err_PC; /* restart instruction */\r | |
316 | break;\r | |
317 | }\r | |
318 | \r | |
319 | O = fp_exec (001, &fpop, op[i + 1], op[i + 2]); /* three-word add */\r | |
320 | WriteOp (op[i].word, fpop, fp_x); /* write sum */\r | |
321 | break;\r | |
322 | \r | |
323 | case 010: /* XSUB 105210 (OP_AAXX) */\r | |
324 | i = 1; /* params start at op[1] */\r | |
325 | XSUB: /* enter here from .XSUB */\r | |
326 | if (intrq) { /* interrupt pending? */\r | |
327 | PC = err_PC; /* restart instruction */\r | |
328 | break;\r | |
329 | }\r | |
330 | \r | |
331 | O = fp_exec (021, &fpop, op[i + 1], op[i + 2]); /* three-word subtract */\r | |
332 | WriteOp (op[i].word, fpop, fp_x); /* write difference */\r | |
333 | break;\r | |
334 | \r | |
335 | case 011: /* XMPY 105211 (OP_AAXX) */\r | |
336 | i = 1; /* params start at op[1] */\r | |
337 | XMPY: /* enter here from .XMPY */\r | |
338 | if (intrq) { /* interrupt pending? */\r | |
339 | PC = err_PC; /* restart instruction */\r | |
340 | break;\r | |
341 | }\r | |
342 | \r | |
343 | O = fp_exec (041, &fpop, op[i + 1], op[i + 2]); /* three-word multiply */\r | |
344 | WriteOp (op[i].word, fpop, fp_x); /* write product */\r | |
345 | break;\r | |
346 | \r | |
347 | case 012: /* XDIV 105212 (OP_AAXX) */\r | |
348 | i = 1; /* params start at op[1] */\r | |
349 | XDIV: /* enter here from .XDIV */\r | |
350 | if (intrq) { /* interrupt pending? */\r | |
351 | PC = err_PC; /* restart instruction */\r | |
352 | break;\r | |
353 | }\r | |
354 | \r | |
355 | O = fp_exec (061, &fpop, op[i + 1], op[i + 2]); /* three-word divide */\r | |
356 | WriteOp (op[i].word, fpop, fp_x); /* write quotient */\r | |
357 | break;\r | |
358 | \r | |
359 | case 013: /* .XADD 105213 (OP_AXX) */\r | |
360 | i = 0; /* params start at op[0] */\r | |
361 | goto XADD; /* process as XADD */\r | |
362 | \r | |
363 | case 014: /* .XSUB 105214 (OP_AXX) */\r | |
364 | i = 0; /* params start at op[0] */\r | |
365 | goto XSUB; /* process as XSUB */\r | |
366 | \r | |
367 | case 015: /* .XCOM 105215 (OP_A) */\r | |
368 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
369 | return stop_inst; /* trap if not */\r | |
370 | \r | |
371 | fpop = ReadOp (op[0].word, fp_x); /* read unpacked */\r | |
372 | AR = fp_ucom (&fpop, fp_x); /* complement and rtn exp adj */\r | |
373 | WriteOp (op[0].word, fpop, fp_x); /* write result */\r | |
374 | break;\r | |
375 | \r | |
376 | case 016: /* ..DCM 105216 (OP_A) */\r | |
377 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
378 | return stop_inst; /* trap if not */\r | |
379 | \r | |
380 | if (intrq) { /* interrupt pending? */\r | |
381 | PC = err_PC; /* restart instruction */\r | |
382 | break;\r | |
383 | }\r | |
384 | \r | |
385 | fpop = ReadOp (op[0].word, fp_x); /* read operand */\r | |
386 | O = fp_pcom (&fpop, fp_x); /* complement (can't ovf neg) */\r | |
387 | WriteOp (op[0].word, fpop, fp_x); /* write result */\r | |
388 | break;\r | |
389 | \r | |
390 | case 017: /* DDINT 105217 (OP_AAX) */\r | |
391 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
392 | return stop_inst; /* trap if not */\r | |
393 | \r | |
394 | if (intrq) { /* interrupt pending? */\r | |
395 | PC = err_PC; /* restart instruction */\r | |
396 | break;\r | |
397 | }\r | |
398 | \r | |
399 | O = fp_trun (&fpop, op[2], fp_x); /* truncate operand (can't ovf) */\r | |
400 | WriteOp (op[1].word, fpop, fp_x); /* write result */\r | |
401 | break;\r | |
402 | \r | |
403 | #endif /* end of int64 support */\r | |
404 | \r | |
405 | /* FFP module 2 */\r | |
406 | \r | |
407 | case 020: /* .XFER 105220 (OP_N) */\r | |
408 | if (UNIT_CPU_TYPE == UNIT_TYPE_2100)\r | |
409 | PC = (PC + 1) & VAMASK; /* 2100 .XFER returns to P+2 */\r | |
410 | XFER: /* enter here from .DFER */\r | |
411 | sc = 3; /* set count for 3-wd xfer */\r | |
412 | goto CFER; /* do transfer */\r | |
413 | \r | |
414 | case 021: /* .GOTO 105221 (OP_AK) */\r | |
415 | if ((int16) op[1].word < 1) /* index < 1? */\r | |
416 | op[1].word = 1; /* reset min */\r | |
417 | \r | |
418 | sa = PC + op[1].word - 1; /* point to jump target */\r | |
419 | if (sa >= op[0].word) /* must be <= last target */\r | |
420 | sa = op[0].word - 1;\r | |
421 | \r | |
422 | da = ReadW (sa); /* get jump target */\r | |
423 | if (reason = resolve (da, &MA, intrq)) { /* resolve indirects */\r | |
424 | PC = err_PC; /* irq restarts instruction */\r | |
425 | break;\r | |
426 | }\r | |
427 | \r | |
428 | mp_dms_jmp (MA); /* validate jump addr */\r | |
429 | PCQ_ENTRY; /* record last PC */\r | |
430 | PC = MA; /* jump */\r | |
431 | BR = op[0].word; /* (for 2100 FFP compat) */\r | |
432 | break;\r | |
433 | \r | |
434 | case 022: /* ..MAP 105222 (OP_KKKK) */\r | |
435 | op[1].word = op[1].word - 1; /* decrement 1st subscr */\r | |
436 | \r | |
437 | if ((AR & 1) == 0) /* 2-dim access? */\r | |
438 | op[1].word = op[1].word + /* compute element offset */\r | |
439 | (op[2].word - 1) * op[3].word;\r | |
440 | else { /* 3-dim access */\r | |
441 | if (reason = cpu_ops (OP_KK, op2, intrq)) { /* get 1st, 2nd ranges */\r | |
442 | PC = err_PC; /* irq restarts instruction */\r | |
443 | break;\r | |
444 | }\r | |
445 | op[1].word = op[1].word + /* offset */\r | |
446 | ((op[3].word - 1) * op2[1].word +\r | |
447 | op[2].word - 1) * op2[0].word;\r | |
448 | }\r | |
449 | \r | |
450 | AR = (op[0].word + op[1].word * BR) & DMASK; /* return element address */\r | |
451 | break;\r | |
452 | \r | |
453 | case 023: /* .ENTR 105223 (OP_A) */\r | |
454 | MA = PC - 3; /* get addr of entry point */\r | |
455 | ENTR: /* enter here from .ENTP */\r | |
456 | da = op[0].word; /* get addr of 1st formal */\r | |
457 | dc = MA - da; /* get count of formals */\r | |
458 | sa = ReadW (MA); /* get addr of return point */\r | |
459 | ra = ReadW (sa++); /* get rtn, ptr to 1st actual */\r | |
460 | WriteW (MA, ra); /* stuff rtn into caller's ent */\r | |
461 | sc = ra - sa; /* get count of actuals */\r | |
462 | if (sc > dc) /* use min (actuals, formals) */\r | |
463 | sc = dc;\r | |
464 | \r | |
465 | for (j = 0; j < sc; j++) {\r | |
466 | MA = ReadW (sa++); /* get addr of actual */\r | |
467 | if (reason = resolve (MA, &MA, intrq)) { /* resolve indirect */\r | |
468 | PC = err_PC; /* irq restarts instruction */\r | |
469 | break;\r | |
470 | }\r | |
471 | WriteW (da++, MA); /* put addr into formal */\r | |
472 | }\r | |
473 | \r | |
474 | AR = ra; /* return address */\r | |
475 | BR = da; /* addr of 1st unused formal */\r | |
476 | break;\r | |
477 | \r | |
478 | case 024: /* .ENTP 105224 (OP_A) */\r | |
479 | MA = PC - 5; /* get addr of entry point */\r | |
480 | goto ENTR;\r | |
481 | \r | |
482 | case 025: /* .PWR2 105225 (OP_RK) */\r | |
483 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
484 | return stop_inst; /* trap if not */\r | |
485 | \r | |
486 | fp_unpack (&fpop, &expon, op[0], fp_f); /* unpack value */\r | |
487 | expon = expon + (int16) (op[1].word); /* multiply by 2**n */\r | |
488 | fp_pack (&fpop, fpop, expon, fp_f); /* repack value */\r | |
489 | AR = fpop.fpk[0]; /* return result */\r | |
490 | BR = fpop.fpk[1]; /* to A/B registers */\r | |
491 | break;\r | |
492 | \r | |
493 | case 026: /* .FLUN 105226 (OP_R) */\r | |
494 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
495 | return stop_inst; /* trap if not */\r | |
496 | \r | |
497 | fp_unpack (&fpop, &expon, op[0], fp_f); /* unpack value */\r | |
498 | AR = (int16) expon; /* return expon to A */\r | |
499 | BR = fpop.fpk[1]; /* and low mant to B */\r | |
500 | break;\r | |
501 | \r | |
502 | case 027: /* $SETP 105227 (OP_K) */\r | |
503 | j = sa = AR; /* save initial value */\r | |
504 | sb = BR; /* save initial address */\r | |
505 | AR = 0; /* AR will return = 0 */\r | |
506 | BR = BR & VAMASK; /* addr must be direct */\r | |
507 | \r | |
508 | do {\r | |
509 | WriteW (BR, j); /* write value to address */\r | |
510 | j = (j + 1) & DMASK; /* incr value */\r | |
511 | BR = (BR + 1) & VAMASK; /* incr address */\r | |
512 | op[0].word = op[0].word - 1; /* decr count */\r | |
513 | if (op[0].word && intrq) { /* more and intr? */\r | |
514 | AR = sa; /* restore A */\r | |
515 | BR = sb; /* restore B */\r | |
516 | PC = err_PC; /* restart instruction */\r | |
517 | break;\r | |
518 | }\r | |
519 | }\r | |
520 | while (op[0].word != 0); /* loop until count exhausted */\r | |
521 | break;\r | |
522 | \r | |
523 | case 030: /* .PACK 105230 (OP_RC) */\r | |
524 | if (UNIT_CPU_TYPE != UNIT_TYPE_1000) /* must be 1000 */\r | |
525 | return stop_inst; /* trap if not */\r | |
526 | \r | |
527 | O = fp_nrpack (&fpop, op[0], /* nrm/rnd/pack value */\r | |
528 | (int16) (op[1].word), fp_f);\r | |
529 | AR = fpop.fpk[0]; /* return result */\r | |
530 | BR = fpop.fpk[1]; /* to A/B registers */\r | |
531 | break;\r | |
532 | \r | |
533 | case 031: /* .CFER 105231 (OP_AA) */\r | |
534 | if ((UNIT_CPU_MODEL != UNIT_1000_E) && /* must be 1000 E-series */\r | |
535 | (UNIT_CPU_MODEL != UNIT_1000_F)) /* or 1000 F-series */\r | |
536 | return stop_inst; /* trap if not */\r | |
537 | \r | |
538 | BR = op[0].word; /* get destination address */\r | |
539 | AR = op[1].word; /* get source address */\r | |
540 | sc = 4; /* set for 4-wd xfer */\r | |
541 | CFER: /* enter here from .XFER */\r | |
542 | for (j = 0; j < sc; j++) { /* xfer loop */\r | |
543 | WriteW (BR, ReadW (AR)); /* transfer word */\r | |
544 | AR = (AR + 1) & VAMASK; /* bump source addr */\r | |
545 | BR = (BR + 1) & VAMASK; /* bump destination addr */\r | |
546 | }\r | |
547 | \r | |
548 | E = 0; /* routine clears E */\r | |
549 | \r | |
550 | if (UNIT_CPU_TYPE == UNIT_TYPE_2100) { /* 2100 (and .DFER/.XFER)? */\r | |
551 | AR = (AR + 1) & VAMASK; /* 2100 FFP returns X+4, Y+4 */\r | |
552 | BR = (BR + 1) & VAMASK;\r | |
553 | }\r | |
554 | break;\r | |
555 | \r | |
556 | default: /* others undefined */\r | |
557 | reason = stop_inst;\r | |
558 | }\r | |
559 | \r | |
560 | return reason;\r | |
561 | }\r | |
562 | \r | |
563 | \r | |
564 | /* Double-Integer Instructions.\r | |
565 | \r | |
566 | The double-integer instructions were added to the HP instruction set at\r | |
567 | revision 1920 of the 1000-F. They were immediately adopted in a number of HP\r | |
568 | software products, most notably the RTE file management package (FMP)\r | |
569 | routines. As these routines are used in nearly every RTE program, F-Series\r | |
570 | programs were almost always a few hundred bytes smaller than their M- and\r | |
571 | E-Series counterparts. This became significant as RTE continued to grow in\r | |
572 | size, and some customer programs ran out of address space on E-Series\r | |
573 | machines.\r | |
574 | \r | |
575 | While HP never added double-integer instructions to the standard E-Series, a\r | |
576 | product from the HP "specials group," HP 93585A, provided microcoded\r | |
577 | replacements for the E-Series. This could provide just enough address-space\r | |
578 | savings to allow programs to load in E-Series systems, in addition to\r | |
579 | accelerating these common operations.\r | |
580 | \r | |
581 | There was no equivalent M-Series microcode, due to the limited micromachine\r | |
582 | address space on that system.\r | |
583 | \r | |
584 | Option implementation by CPU was as follows:\r | |
585 | \r | |
586 | 2114 2115 2116 2100 1000-M 1000-E 1000-F\r | |
587 | ------ ------ ------ ------ ------ ------ ------\r | |
588 | N/A N/A N/A N/A N/A 93585A std\r | |
589 | \r | |
590 | The routines are mapped to instruction codes as follows:\r | |
591 | \r | |
592 | Instr. 1000-E 1000-F Description\r | |
593 | ------ ------ ------ -----------------------------------------\r | |
594 | [test] 105320 -- [self test]\r | |
595 | .DAD 105321 105014 Double integer add\r | |
596 | .DMP 105322 105054 Double integer multiply\r | |
597 | .DNG 105323 105203 Double integer negate\r | |
598 | .DCO 105324 105204 Double integer compare\r | |
599 | .DDI 105325 105074 Double integer divide\r | |
600 | .DDIR 105326 105134 Double integer divide (reversed)\r | |
601 | .DSB 105327 105034 Double integer subtract\r | |
602 | .DIN 105330 105210 Double integer increment\r | |
603 | .DDE 105331 105211 Double integer decrement\r | |
604 | .DIS 105332 105212 Double integer increment and skip if zero\r | |
605 | .DDS 105333 105213 Double integer decrement and skip if zero\r | |
606 | .DSBR 105334 105114 Double integer subtraction (reversed)\r | |
607 | \r | |
608 | On the F-Series, the double-integer instruction codes are split among the\r | |
609 | floating-point processor and the Fast FORTRAN Processor ranges. They are\r | |
610 | dispatched from those respective simulators for processing here.\r | |
611 | \r | |
612 | Notes:\r | |
613 | \r | |
614 | 1. Opcodes 105335-105337 are NOPs in the microcode. They generate\r | |
615 | unimplemented instructions stops under simulation.\r | |
616 | \r | |
617 | 2. This is an implementation of Revision 2 of the microcode, which was\r | |
618 | released as ROM part numbers 93585-80003, 93585-80005, and 93585-80001\r | |
619 | (Revision 1 substituted -80002 for -80005).\r | |
620 | \r | |
621 | 3. The F-Series firmware executes .DMP and .DDI/.DDIR by floating the\r | |
622 | 32-bit double integer to a 48-bit extended-precision number, calling the\r | |
623 | FPP to execute the extended-precision multiply/divide, and then fixing\r | |
624 | the product to a 32-bit double integer. We simulate these directly with\r | |
625 | 64- or 32-bit integer arithmetic.\r | |
626 | \r | |
627 | Additional references:\r | |
628 | - 93585A Microcode Source (93585-18002 Rev. 2005)\r | |
629 | - 93585A Double Integer Instructions Installation and Reference Manual\r | |
630 | (93585-90007)\r | |
631 | */\r | |
632 | \r | |
633 | static const OP_PAT op_dbi[16] = {\r | |
634 | OP_N, OP_JD, OP_JD, OP_J, /* [test] .DAD .DMP .DNG */\r | |
635 | OP_JD, OP_JD, OP_JD, OP_JD, /* .DCO .DDI .DDIR .DSB */\r | |
636 | OP_J, OP_J, OP_A, OP_A, /* .DIN .DDE .DIS .DDS */\r | |
637 | OP_JD, OP_N, OP_N, OP_N /* .DSBR --- --- --- */\r | |
638 | };\r | |
639 | \r | |
640 | t_stat cpu_dbi (uint32 IR, uint32 intrq)\r | |
641 | {\r | |
642 | OP din;\r | |
643 | OPS op;\r | |
644 | uint32 entry, t;\r | |
645 | t_stat reason = SCPE_OK;\r | |
646 | \r | |
647 | if ((cpu_unit.flags & UNIT_DBI) == 0) /* DBI option installed? */\r | |
648 | return stop_inst;\r | |
649 | \r | |
650 | entry = IR & 017; /* mask to entry point */\r | |
651 | \r | |
652 | if (op_dbi[entry] != OP_N)\r | |
653 | if (reason = cpu_ops (op_dbi[entry], op, intrq)) /* get instruction operands */\r | |
654 | return reason;\r | |
655 | \r | |
656 | switch (entry) { /* decode IR<3:0> */\r | |
657 | \r | |
658 | case 000: /* [test] 105320 (OP_N) */\r | |
659 | XR = 2; /* set revision */\r | |
660 | BR = 0377; /* side effect of microcode */\r | |
661 | SR = 0102077; /* set "pass" code */\r | |
662 | PC = (PC + 1) & VAMASK; /* return to P+1 */\r | |
663 | t = (AR << 16) | BR; /* set t for return */\r | |
664 | break;\r | |
665 | \r | |
666 | case 001: /* .DAD 105321 (OP_JD) */\r | |
667 | t = op[0].dword + op[1].dword; /* add values */\r | |
668 | E = E | (t < op[0].dword); /* carry if result smaller */\r | |
669 | O = (((~op[0].dword ^ op[1].dword) & /* overflow if sign wrong */\r | |
670 | (op[0].dword ^ t) & SIGN32) != 0);\r | |
671 | break;\r | |
672 | \r | |
673 | case 002: /* .DMP 105322 (OP_JD) */\r | |
674 | {\r | |
675 | \r | |
676 | #if defined (HAVE_INT64) /* int64 support available */\r | |
677 | \r | |
678 | t_int64 t64;\r | |
679 | \r | |
680 | t64 = (t_int64) INT32 (op[0].dword) * /* multiply signed values */\r | |
681 | (t_int64) INT32 (op[1].dword);\r | |
682 | O = ((t64 < -(t_int64) 0x80000000) || /* overflow if out of range */\r | |
683 | (t64 > (t_int64) 0x7FFFFFFF));\r | |
684 | if (O)\r | |
685 | t = ~SIGN32; /* if overflow, rtn max pos */\r | |
686 | else\r | |
687 | t = (uint32) (t64 & DMASK32); /* else lower 32 bits of result */\r | |
688 | \r | |
689 | #else /* int64 support unavailable */\r | |
690 | \r | |
691 | uint32 sign, xu, yu, rh, rl;\r | |
692 | \r | |
693 | sign = ((int32) op[0].dword < 0) ^ /* save sign of result */\r | |
694 | ((int32) op[1].dword < 0);\r | |
695 | \r | |
696 | xu = (uint32) abs ((int32) op[0].dword); /* make operands pos */\r | |
697 | yu = (uint32) abs ((int32) op[1].dword);\r | |
698 | \r | |
699 | if ((xu & 0xFFFF0000) == 0 && /* 16 x 16 multiply? */\r | |
700 | (yu & 0xFFFF0000) == 0) {\r | |
701 | t = xu * yu; /* do it */\r | |
702 | O = 0; /* can't overflow */\r | |
703 | }\r | |
704 | \r | |
705 | else if ((xu & 0xFFFF0000) != 0 && /* 32 x 32 multiply? */\r | |
706 | (yu & 0xFFFF0000) != 0)\r | |
707 | O = 1; /* always overflows */\r | |
708 | \r | |
709 | else { /* 16 x 32 or 32 x 16 */\r | |
710 | rl = (xu & 0xFFFF) * (yu & 0xFFFF); /* form 1st partial product */\r | |
711 | \r | |
712 | if ((xu & 0xFFFF0000) == 0)\r | |
713 | rh = xu * (yu >> 16) + (rl >> 16); /* 16 x 32 2nd partial */\r | |
714 | else\r | |
715 | rh = (xu >> 16) * yu + (rl >> 16); /* 32 x 16 2nd partial */\r | |
716 | \r | |
717 | O = (rh > 0x7FFF + sign); /* check for out of range */\r | |
718 | if (O == 0)\r | |
719 | t = (rh << 16) | (rl & 0xFFFF); /* combine partials */\r | |
720 | }\r | |
721 | \r | |
722 | if (O)\r | |
723 | t = ~SIGN32; /* if overflow, rtn max pos */\r | |
724 | else if (sign)\r | |
725 | t = ~t + 1; /* if result neg, 2s compl */\r | |
726 | \r | |
727 | #endif /* end of int64 support */\r | |
728 | \r | |
729 | }\r | |
730 | break;\r | |
731 | \r | |
732 | case 003: /* .DNG 105323 (OP_J) */\r | |
733 | t = ~op[0].dword + 1; /* negate value */\r | |
734 | O = (op[0].dword == SIGN32); /* overflow if max neg */\r | |
735 | if (op[0].dword == 0) /* borrow if result zero */\r | |
736 | E = 1;\r | |
737 | break;\r | |
738 | \r | |
739 | case 004: /* .DCO 105324 (OP_JD) */\r | |
740 | t = op[0].dword; /* copy for later store */\r | |
741 | if ((int32) op[0].dword < (int32) op[1].dword)\r | |
742 | PC = (PC + 1) & VAMASK; /* < rtns to P+2 */\r | |
743 | else if ((int32) op[0].dword > (int32) op[1].dword)\r | |
744 | PC = (PC + 2) & VAMASK; /* > rtns to P+3 */\r | |
745 | break; /* = rtns to P+1 */\r | |
746 | \r | |
747 | case 005: /* .DDI 105325 (OP_JD) */\r | |
748 | DDI:\r | |
749 | O = ((op[1].dword == 0) || /* overflow if div 0 */\r | |
750 | ((op[0].dword == SIGN32) && /* or max neg div -1 */\r | |
751 | ((int32) op[1].dword == -1)));\r | |
752 | if (O)\r | |
753 | t = ~SIGN32; /* rtn max pos for ovf */\r | |
754 | else\r | |
755 | t = (uint32) (INT32 (op[0].dword) / /* else return quotient */\r | |
756 | INT32 (op[1].dword));\r | |
757 | break;\r | |
758 | \r | |
759 | case 006: /* .DDIR 105326 (OP_JD) */\r | |
760 | t = op[0].dword; /* swap operands */\r | |
761 | op[0].dword = op[1].dword;\r | |
762 | op[1].dword = t;\r | |
763 | goto DDI; /* continue at .DDI */\r | |
764 | \r | |
765 | case 007: /* .DSB 105327 (OP_JD) */\r | |
766 | DSB:\r | |
767 | t = op[0].dword - op[1].dword; /* subtract values */\r | |
768 | E = E | (op[0].dword < op[1].dword); /* borrow if minu < subtr */\r | |
769 | O = (((op[0].dword ^ op[1].dword) & /* overflow if sign wrong */\r | |
770 | (op[0].dword ^ t) & SIGN32) != 0);\r | |
771 | break;\r | |
772 | \r | |
773 | case 010: /* .DIN 105330 (OP_J) */\r | |
774 | t = op[0].dword + 1; /* increment value */\r | |
775 | O = (t == SIGN32); /* overflow if sign flipped */\r | |
776 | if (t == 0)\r | |
777 | E = 1; /* carry if result zero */\r | |
778 | break;\r | |
779 | \r | |
780 | case 011: /* .DDE 105331 (OP_J) */\r | |
781 | t = op[0].dword - 1; /* decrement value */\r | |
782 | O = (t == ~SIGN32); /* overflow if sign flipped */\r | |
783 | if ((int32) t == -1)\r | |
784 | E = 1; /* borrow if result -1 */\r | |
785 | break;\r | |
786 | \r | |
787 | case 012: /* .DIS 105332 (OP_A) */\r | |
788 | din = ReadOp (op[0].word, in_d); /* get value */\r | |
789 | t = din.dword = din.dword + 1; /* increment value */\r | |
790 | WriteOp (op[0].word, din, in_d); /* store it back */\r | |
791 | if (t == 0)\r | |
792 | PC = (PC + 1) & VAMASK; /* skip if result zero */\r | |
793 | break;\r | |
794 | \r | |
795 | case 013: /* .DDS 105333 (OP_A) */\r | |
796 | din = ReadOp (op[0].word, in_d); /* get value */\r | |
797 | t = din.dword = din.dword - 1; /* decrement value */\r | |
798 | WriteOp (op[0].word, din, in_d); /* write it back */\r | |
799 | if (t == 0)\r | |
800 | PC = (PC + 1) & VAMASK; /* skip if result zero */\r | |
801 | break;\r | |
802 | \r | |
803 | case 014: /* .DSBR 105334 (OP_JD) */\r | |
804 | t = op[0].dword; /* swap operands */\r | |
805 | op[0].dword = op[1].dword;\r | |
806 | op[1].dword = t;\r | |
807 | goto DSB; /* continue at .DSB */\r | |
808 | \r | |
809 | default: /* others undefined */\r | |
810 | t = (AR << 16) | BR; /* set t for NOP */\r | |
811 | reason = stop_inst;\r | |
812 | }\r | |
813 | \r | |
814 | if (reason == SCPE_OK) { /* if return OK */\r | |
815 | AR = (t >> 16) & DMASK; /* break result */\r | |
816 | BR = t & DMASK; /* into A and B */\r | |
817 | }\r | |
818 | \r | |
819 | return reason;\r | |
820 | }\r |