TP3/shell/Exec86.mod

IMPLEMENTATION MODULE Exec86 ;

(* Exec86 -- implementation.  See Exec86.def for what this is for.

   WHAT IS IMPLEMENTED, and where the list comes from
   --------------------------------------------------
   Not "the 8086": a CPU has no meaning without the programs it must run, and
   this one has a corpus.  The set below is the union of exactly two measured
   things:

     (a) every byte the runtime emits.  Runtime.mod's code region is pure
         code with no inline data, so it can be swept instruction by
         instruction and the sweep must complete -- tests/check_8086.py does
         that, and it covers 219 instructions, 121 distinct forms.  That
         sweep is the authority for the runtime.

     (b) every byte Compiler.mod's emitters can write.  The generated code
         region CANNOT be swept the same way: inline string literals are
         emitted into it after the code, and a linear sweep desynchronises
         on them (t09_if dies at the bytes `FE E9 0D 00', which are ASCII
         text).  So the authority there is the source -- the Em* procedures
         and their Ebyte constants -- not a disassembly.

   Everything outside that union faults rather than guessing.  An
   interpreter that guesses at an unknown opcode does not fail; it produces
   an answer.

   FLAGS: CF, ZF, SF and OF are maintained, because every condition the
   corpus uses reads one of them: the compiler emits 4,5,C,D,E,F
   (JE JNE JL JGE JLE JG) and the runtime adds 2,6,7 (JB JBE JA).
   PF and AF are NOT maintained, and JP/JNP fault saying so rather than
   returning a value nobody computed.  DF, IF and TF are not maintained;
   no string instruction is implemented, so nothing can read DF.  Nothing in
   the corpus sets a flag that a later instruction in the corpus reads
   except through those four.

   SEGMENTS are checked every step.  The machine is 64 KB flat, so a
   non-zero segment register would alias silently rather than fault; it
   faults instead.

   INT 21h PRESERVES THE FLAGS.  That is not an approximation: a real INT
   pushes FLAGS, and IRET pops them back, so the handler's own CLC/STC are
   discarded before the caller can see them.  bootcom.s does `clc' and
   `stc' in its handler and they change nothing outside it.  This is the
   one place where matching the machine rather than the visible source is
   easy to get wrong, so it is written down.

   INT 10h is also provided, for the CRT builtins the compiler emits.  There is
   no display model: the cursor is tracked (AH=02/AH=03) and the screen calls
   are no-ops, so the CONSOLE output this interpreter captures - which is what
   the execution oracles compare - is identical to qemu's.  See DoInt10. *)

FROM Posix IMPORT read, write ;
FROM SYSTEM IMPORT ADR ;

CONST
   STDIN    = 0 ;
   STDOUT   = 1 ;
   STDERR   = 2 ;
   LoadAt   = 100H ;          (* where DOS puts a .COM, and where bootcom
                                 jumps, so the entry point matches qemu *)
   MaxSteps = 2000000000 ;    (* runaway guard; see Exec86.def *)

VAR
   mem   : ARRAY [0..65535] OF CARDINAL ;   (* one CARDINAL per byte, 0..255 *)
   AX, BX, CX, DX, SI, DI, BP, SP, IP : CARDINAL ;
   CS, DS, ES, SS : CARDINAL ;
   CF, ZF, SF, OFl : BOOLEAN ;
   halted   : BOOLEAN ;
   haltCode : CARDINAL ;
   isFault  : BOOLEAN ;
   faultIP  : CARDINAL ;
   loadHi   : CARDINAL ;      (* one past the highest address poked *)
   stepCnt  : LONGCARD ;
   curRow, curCol : CARDINAL ; (* INT 10h's cursor, for AH=02/AH=03 *)

   (* filled in by DoModRM *)
   eaAddr   : CARDINAL ;
   eaReg    : CARDINAL ;
   eaIsReg  : BOOLEAN ;
   rmReg    : CARDINAL ;


(* ------------------------------------------------------------ diagnostics *)

PROCEDURE WrErr1 (c : CHAR) ;
VAR n : LONGINT ;
BEGIN
   n := write (STDERR, ADR (c), 1)
END WrErr1 ;

PROCEDURE WrS (s : ARRAY OF CHAR) ;
VAR i : CARDINAL ;
    c : CHAR ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (s)) AND (s [i] # 0C) DO
      c := s [i] ;
      WrErr1 (c) ;
      i := i + 1
   END
END WrS ;

PROCEDURE WrHex (v : CARDINAL) ;
VAR k, d, p, n : CARDINAL ;
    c : CHAR ;
BEGIN
   WrS ("0x") ;
   FOR k := 0 TO 3 DO
      p := 1 ;
      d := 3 - k ;
      WHILE d > 0 DO
         p := p * 16 ;
         d := d - 1
      END ;
      n := (v DIV p) MOD 16 ;
      IF n < 10 THEN
         c := CHR (ORD ('0') + n)
      ELSE
         c := CHR (ORD ('A') + n - 10)
      END ;
      WrErr1 (c)
   END
END WrHex ;

PROCEDURE WrDec (v : CARDINAL) ;
VAR buf : ARRAY [0..10] OF CHAR ;
    k, j, x : CARDINAL ;
    c : CHAR ;
BEGIN
   k := 10 ;
   buf [10] := 0C ;
   x := v ;
   REPEAT
      k := k - 1 ;
      buf [k] := CHR (ORD ('0') + x MOD 10) ;
      x := x DIV 10
   UNTIL x = 0 ;
   j := k ;
   WHILE j <= 9 DO
      c := buf [j] ;
      WrErr1 (c) ;
      j := j + 1
   END
END WrDec ;

PROCEDURE Fault (msg : ARRAY OF CHAR) ;
BEGIN
   isFault := TRUE ;
   WrS ("exec86: fault at IP=") ;
   WrHex (faultIP) ;
   WrS (": ") ;
   WrS (msg) ;
   WrErr1 (CHR (10))
END Fault ;


(* --------------------------------------------------- widths and sign bits *)

PROCEDURE Sz (w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN RETURN 65536 ELSE RETURN 256 END
END Sz ;

(* The value with only the sign bit set, for a byte (80H) or word (8000H). *)
PROCEDURE Sg (w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN RETURN 8000H ELSE RETURN 80H END
END Sg ;

(* A signed byte widened to a 16-bit two's-complement CARDINAL, so that
   adding it does the right thing modulo 65536.  128 -> 65408 = -128. *)
PROCEDURE SE8 (v : CARDINAL) : CARDINAL ;
BEGIN
   IF v >= 80H THEN RETURN v + 65280 ELSE RETURN v END
END SE8 ;

(* Signed interpretations, for MUL/IMUL/DIV/IDIV. *)
PROCEDURE S16 (v : CARDINAL) : LONGINT ;
BEGIN
   IF v >= 8000H THEN
      RETURN VAL (LONGINT, v) - VAL (LONGINT, 65536)
   ELSE
      RETURN VAL (LONGINT, v)
   END
END S16 ;

PROCEDURE S8 (v : CARDINAL) : LONGINT ;
BEGIN
   IF v >= 80H THEN
      RETURN VAL (LONGINT, v) - VAL (LONGINT, 256)
   ELSE
      RETURN VAL (LONGINT, v)
   END
END S8 ;


(* --------------------------------------------------------- memory and stack *)

PROCEDURE MemWr (a, v, w : CARDINAL) ;
BEGIN
   mem [a] := v MOD 256 ;
   IF w = 1 THEN
      mem [(a + 1) MOD 65536] := (v DIV 256) MOD 256
   END
END MemWr ;

PROCEDURE MemRd (a, w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN
      RETURN mem [a] + 256 * mem [(a + 1) MOD 65536]
   ELSE
      RETURN mem [a]
   END
END MemRd ;

PROCEDURE Push (v : CARDINAL) ;
BEGIN
   SP := (SP + 65534) MOD 65536 ;        (* SP - 2, wrapped *)
   MemWr (SP, v, 1)
END Push ;

PROCEDURE Pop () : CARDINAL ;
VAR v : CARDINAL ;
BEGIN
   v := MemRd (SP, 1) ;
   SP := (SP + 2) MOD 65536 ;
   RETURN v
END Pop ;

PROCEDURE Fetch8 () : CARDINAL ;
VAR v : CARDINAL ;
BEGIN
   v := mem [IP] ;
   IP := (IP + 1) MOD 65536 ;
   RETURN v
END Fetch8 ;

PROCEDURE Fetch16 () : CARDINAL ;
VAR a, b : CARDINAL ;
BEGIN
   a := Fetch8 () ;
   b := Fetch8 () ;
   RETURN a + 256 * b
END Fetch16 ;


(* --------------------------------------------------------------- registers *)

PROCEDURE GetReg (r, w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN
      CASE r OF
      | 0 : RETURN AX
      | 1 : RETURN CX
      | 2 : RETURN DX
      | 3 : RETURN BX
      | 4 : RETURN SP
      | 5 : RETURN BP
      | 6 : RETURN SI
      ELSE  RETURN DI
      END
   ELSE
      CASE r OF
      | 0 : RETURN AX MOD 256          (* AL *)
      | 1 : RETURN CX MOD 256          (* CL *)
      | 2 : RETURN DX MOD 256          (* DL *)
      | 3 : RETURN BX MOD 256          (* BL *)
      | 4 : RETURN AX DIV 256          (* AH *)
      | 5 : RETURN CX DIV 256          (* CH *)
      | 6 : RETURN DX DIV 256          (* DH *)
      ELSE  RETURN BX DIV 256          (* BH *)
      END
   END
END GetReg ;

PROCEDURE PutReg (r, w, v : CARDINAL) ;
VAR hi, lo : CARDINAL ;
BEGIN
   IF w = 1 THEN
      CASE r OF
      | 0 : AX := v
      | 1 : CX := v
      | 2 : DX := v
      | 3 : BX := v
      | 4 : SP := v
      | 5 : BP := v
      | 6 : SI := v
      ELSE  DI := v
      END
   ELSE
      lo := v MOD 256 ;
      CASE r OF
      | 0 : AX := (AX DIV 256) * 256 + lo          (* AL *)
      | 1 : CX := (CX DIV 256) * 256 + lo          (* CL *)
      | 2 : DX := (DX DIV 256) * 256 + lo          (* DL *)
      | 3 : BX := (BX DIV 256) * 256 + lo          (* BL *)
      | 4 : hi := lo * 256 ; AX := (AX MOD 256) + hi   (* AH *)
      | 5 : hi := lo * 256 ; CX := (CX MOD 256) + hi   (* CH *)
      | 6 : hi := lo * 256 ; DX := (DX MOD 256) + hi   (* DH *)
      ELSE  hi := lo * 256 ; BX := (BX MOD 256) + hi   (* BH *)
      END
   END
END PutReg ;


(* ---------------------------------------------------------- addressing mode *)

PROCEDURE DoModRM (w : CARDINAL) ;
(* Fetch the ModR/M byte and, if the operand is in memory, its displacement.
   `w' is only needed so the caller can size the access afterwards; the
   address is the same either way.

   The 16-bit addressing modes, since this is the part where a wrong table
   still decodes cleanly and just reads the wrong variable:

      rm  mod=00        mod=01/10
       0   [BX+SI]      [BX+SI+disp]
       1   [BX+DI]      [BX+DI+disp]
       2   [BP+SI]      [BP+SI+disp]
       3   [BP+DI]      [BP+DI+disp]
       4   [SI]         [SI+disp]
       5   [DI]         [DI+disp]
       6   [disp16]     [BP+disp]     <- mod=00,rm=6 is the ONLY direct form
       7   [BX]         [BX+disp]

   Displacements are signed, and adding them modulo 65536 is exactly two's
   complement addition, so no branch is needed for a negative one.  SE8
   handles the disp8 case by widening it first. *)
VAR b, md, rg, rm, base, d : CARDINAL ;
BEGIN
   b := Fetch8 () ;
   md := b DIV 64 ;
   rg := (b DIV 8) MOD 8 ;
   rm := b MOD 8 ;
   rmReg := rg ;
   IF md = 3 THEN
      eaIsReg := TRUE ;
      eaReg := rm ;
      eaAddr := 0
   ELSE
      eaIsReg := FALSE ;
      eaReg := 0 ;
      CASE rm OF
      | 0 : base := (BX + SI) MOD 65536
      | 1 : base := (BX + DI) MOD 65536
      | 2 : base := (BP + SI) MOD 65536
      | 3 : base := (BP + DI) MOD 65536
      | 4 : base := SI
      | 5 : base := DI
      | 6 : base := BP
      ELSE  base := BX
      END ;
      IF (md = 0) AND (rm = 6) THEN
         eaAddr := Fetch16 ()
      ELSIF md = 0 THEN
         eaAddr := base
      ELSIF md = 1 THEN
         d := Fetch8 () ;
         eaAddr := (base + SE8 (d)) MOD 65536
      ELSE
         d := Fetch16 () ;
         eaAddr := (base + d) MOD 65536
      END
   END
END DoModRM ;

PROCEDURE RmRd (w : CARDINAL) : CARDINAL ;
BEGIN
   IF eaIsReg THEN
      RETURN GetReg (eaReg, w)
   ELSE
      RETURN MemRd (eaAddr, w)
   END
END RmRd ;

PROCEDURE RmWr (v, w : CARDINAL) ;
BEGIN
   IF eaIsReg THEN
      PutReg (eaReg, w, v)
   ELSE
      MemWr (eaAddr, v, w)
   END
END RmWr ;


(* ------------------------------------------------------------------- flags *)

PROCEDURE SetZSF (r, w : CARDINAL) ;
(* ZF and SF from the result.  PF is deliberately absent: see the header. *)
BEGIN
   ZF := r = 0 ;
   SF := r >= Sg (w)
END SetZSF ;

PROCEDURE DoAdd (a, b, cin, w : CARDINAL) : CARDINAL ;
(* a + b + cin, setting the flags.  raw is at most 65535+65535+1, so it
   never overflows the 32-bit CARDINAL and the carry can be read off it
   directly rather than inferred from a wrapped result. *)
VAR raw, res, sz : CARDINAL ;
    ex : LONGINT ;
BEGIN
   sz := Sz (w) ;
   raw := a + b + cin ;
   res := raw MOD sz ;
   CF := raw >= sz ;
   (* OF: the exact mathematical result left the signed range.  Computing it
      exactly, rather than from the signs of the two operands, is what makes
      ADC work too: the carry can turn 127+0 into 128, and the two sign bits
      alone say nothing about that.  S16/S8 are the signed readings of a
      value at this width, so the whole test is one addition and a range
      check. *)
   IF w = 1 THEN
      ex := S16 (a) + S16 (b) + VAL (LONGINT, cin) ;
      OFl := (ex < VAL (LONGINT, -32768)) OR (ex > VAL (LONGINT, 32767))
   ELSE
      ex := S8 (a) + S8 (b) + VAL (LONGINT, cin) ;
      OFl := (ex < VAL (LONGINT, -128)) OR (ex > VAL (LONGINT, 127))
   END ;
   SetZSF (res, w) ;
   RETURN res
END DoAdd ;

PROCEDURE DoSub (a, b, cin, w : CARDINAL) : CARDINAL ;
(* Subtracts b and a borrow.  Same reason for computing OF exactly: with
   cin = 1 and b = 127 the subtrahend is really 128, whose sign bit is not
   the sign bit of b, so the sign-bit rule gets SBB wrong. *)
VAR sz, res, bb : CARDINAL ;
    ex : LONGINT ;
BEGIN
   sz := Sz (w) ;
   bb := b + cin ;
   IF a >= bb THEN
      res := a - bb ;              (* CARDINAL is 32-bit, so this cannot wrap *)
      CF := FALSE
   ELSE
      res := a + sz - bb ;         (* a + sz >= bb always, so still non-negative *)
      CF := TRUE
   END ;
   res := res MOD sz ;
   IF w = 1 THEN
      ex := S16 (a) - S16 (b) - VAL (LONGINT, cin) ;
      OFl := (ex < VAL (LONGINT, -32768)) OR (ex > VAL (LONGINT, 32767))
   ELSE
      ex := S8 (a) - S8 (b) - VAL (LONGINT, cin) ;
      OFl := (ex < VAL (LONGINT, -128)) OR (ex > VAL (LONGINT, 127))
   END ;
   SetZSF (res, w) ;
   RETURN res
END DoSub ;

PROCEDURE SetLogic (r, w : CARDINAL) ;
BEGIN
   CF := FALSE ;
   OFl := FALSE ;
   SetZSF (r, w)
END SetLogic ;

(* Bitwise operations.  This dialect has NO bitwise operators at all - no
   BITAND, no BAND, no `&' - so sets stand in for them, which is the same
   trick Compiler.mod uses for its own constant folding (BitAnd/BitOr/BitNot
   there are three lines of this).  `+' is union, `*' is intersection,
   `-` is difference, so XOR is union minus intersection. *)
PROCEDURE BAnd (a, b, w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN
      RETURN CARDINAL (VAL (BITSET, a) * VAL (BITSET, b))
   ELSE
      RETURN CARDINAL (VAL (BITSET, a MOD 256) * VAL (BITSET, b MOD 256))
   END
END BAnd ;

PROCEDURE BOr (a, b, w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN
      RETURN CARDINAL (VAL (BITSET, a) + VAL (BITSET, b))
   ELSE
      RETURN CARDINAL (VAL (BITSET, a MOD 256) + VAL (BITSET, b MOD 256))
   END
END BOr ;

PROCEDURE BXor (a, b, w : CARDINAL) : CARDINAL ;
VAR u, i : BITSET ;
BEGIN
   IF w = 1 THEN
      u := VAL (BITSET, a) + VAL (BITSET, b) ;
      i := VAL (BITSET, a) * VAL (BITSET, b)
   ELSE
      u := VAL (BITSET, a MOD 256) + VAL (BITSET, b MOD 256) ;
      i := VAL (BITSET, a MOD 256) * VAL (BITSET, b MOD 256)
   END ;
   RETURN CARDINAL (u - i)
END BXor ;

PROCEDURE BNot (a, w : CARDINAL) : CARDINAL ;
BEGIN
   IF w = 1 THEN
      RETURN CARDINAL (VAL (BITSET, 0FFFFH) - VAL (BITSET, a))
   ELSE
      RETURN CARDINAL (VAL (BITSET, 0FFH) - VAL (BITSET, a MOD 256))
   END
END BNot ;

PROCEDURE Alu (op, a, b, w : CARDINAL) : CARDINAL ;
(* op is the group's reg field: 0 ADD 1 OR 2 ADC 3 SBB 4 AND 5 SUB 6 XOR
   7 CMP.  The result is returned for every op, including CMP; the caller
   decides whether to write it back, which is what the /r bit of the
   instruction already says. *)
VAR cin, res : CARDINAL ;
BEGIN
   IF (op = 2) OR (op = 3) THEN
      IF CF THEN cin := 1 ELSE cin := 0 END
   ELSE
      cin := 0
   END ;
   CASE op OF
   | 0 : res := DoAdd (a, b, cin, w)
   | 1 : res := BOr (a, b, w) ;  SetLogic (res, w)
   | 2 : res := DoAdd (a, b, cin, w)
   | 3 : res := DoSub (a, b, cin, w)
   | 4 : res := BAnd (a, b, w) ; SetLogic (res, w)
   | 5 : res := DoSub (a, b, cin, w)
   | 6 : res := BXor (a, b, w) ; SetLogic (res, w)
   ELSE  res := DoSub (a, b, cin, w)
   END ;
   RETURN res
END Alu ;

PROCEDURE Cond (n : CARDINAL) : BOOLEAN ;
(* The 16 conditions.  0AH and 0BH need PF, which this machine does not
   maintain, so they fault instead of answering. *)
VAR r : BOOLEAN ;
BEGIN
   CASE n OF
   | 0H  : r := OFl                       (* JO  *)
   | 1H  : r := NOT OFl                   (* JNO *)
   | 2H  : r := CF                        (* JB  *)
   | 3H  : r := NOT CF                    (* JAE *)
   | 4H  : r := ZF                        (* JE  *)
   | 5H  : r := NOT ZF                    (* JNE *)
   | 6H  : r := CF OR ZF                  (* JBE *)
   | 7H  : r := NOT (CF OR ZF)            (* JA  *)
   | 8H  : r := SF                        (* JS  *)
   | 9H  : r := NOT SF                    (* JNS *)
   | 0AH : Fault ("parity flag is not maintained, so JP cannot be evaluated")
          ; r := FALSE
   | 0BH : Fault ("parity flag is not maintained, so JNP cannot be evaluated")
          ; r := FALSE
   | 0CH : r := SF # OFl                  (* JL  *)
   | 0DH : r := SF = OFl                  (* JGE *)
   | 0EH : r := ZF OR (SF # OFl)          (* JLE *)
   ELSE    r := (NOT ZF) AND (SF = OFl)   (* JG  *)
   END ;
   RETURN r
END Cond ;


(* ----------------------------------------------------------------- INT 10h *)

PROCEDURE DoInt10 ;
(* The BIOS screen services this compiler emits, and nothing else.  There is no
   display model here: the CURSOR is tracked so AH=03 can answer it, and the
   screen operations (AH=06 clear/scroll, AH=00 set mode) are no-ops that home
   the cursor.  That is the honest shape, not a convenience: the interpreter
   captures the guest's CONSOLE output through INT 21h, which is what
   run_com_exec compares, and the BIOS writes to VGA memory, which no oracle
   here looks at.  So a program that clears the screen and then prints agrees
   with qemu byte for byte.  Anything else faults, as with INT 21h: inventing a
   video BIOS would be worse than saying it is not there. *)
VAR ah : CARDINAL ;
BEGIN
   ah := AX DIV 256 ;
   IF ah = 02H THEN                            (* set cursor: DH=row, DL=col *)
      curRow := DX DIV 256 ;
      curCol := DX MOD 256
   ELSIF ah = 03H THEN                         (* get cursor -> DH,DL *)
      DX := ((curRow MOD 256) * 256 + (curCol MOD 256)) MOD 65536
   ELSIF (ah = 06H) OR (ah = 00H) THEN
      (* clear/scroll or set mode: no display to change; the cursor homes *)
      curRow := 0 ;
      curCol := 0
   ELSE
      WrS ("exec86: INT 10h function ") ;
      WrHex (ah) ;
      WrS (" is not implemented") ;
      Fault ("unsupported INT 10h function")
   END
END DoInt10 ;

(* ----------------------------------------------------------------- INT 21h *)

PROCEDURE DoInt21 ;
(* The four services bootcom.s provides and the runtime calls, and nothing
   else.  Anything else faults, because the alternative is inventing DOS.

   No flag is touched anywhere in here: IRET restores the caller's FLAGS, so
   neither this code nor bootcom's CLC/STC is visible to the guest. *)
VAR ah, b, a, n, lim, stop : CARDINAL ;
    c : CHAR ;
    running : BOOLEAN ;
BEGIN
   ah := AX DIV 256 ;
   CASE ah OF
   | 02H :                                   (* display character in AL *)
      c := CHR (AX MOD 256) ;
      n := write (STDOUT, ADR (c), 1)

   | 09H :                                   (* $-terminated string at DS:DX *)
      a := DX ;
      running := TRUE ;
      lim := 0 ;
      WHILE running DO
         b := mem [a] ;
         IF b = 24H THEN                     (* '$' *)
            running := FALSE
         ELSE
            c := CHR (b) ;
            n := write (STDOUT, ADR (c), 1) ;
            a := (a + 1) MOD 65536 ;
            lim := lim + 1 ;
            IF lim > 65536 THEN
               Fault ("INT 21h AH=09: walked the whole address space with no $") ;
               running := FALSE
            END
         END
      END

   | 08H :                                   (* read a character, no echo *)
      n := read (STDIN, ADR (c), 1) ;
      IF n = 1 THEN
         b := ORD (c)
      ELSE
         b := 1AH                            (* end of input, as bootcom does *)
      END ;
      AX := (AX DIV 256) * 256 + b           (* AL only: AH is the function *)

   | 04CH :                                  (* terminate *)
      halted := TRUE ;
      haltCode := AX MOD 256

   ELSE
      stop := ah ;
      WrS ("exec86: INT 21h function ") ;
      WrHex (stop) ;
      WrS (" is not implemented") ;
      Fault ("unsupported INT 21h function")
   END
END DoInt21 ;


(* ------------------------------------------------------ F6/F7 unary group *)

PROCEDURE DoUnaryGroup (w : CARDINAL) ;
(* F6/F7, after DoModRM has run.  reg selects:
      /0 /1 TEST  /2 NOT  /3 NEG  /4 MUL  /5 IMUL  /6 DIV  /7 IDIV *)
VAR k, src, res, prod, q, remw : CARDINAL ;
    ma, mb, mq, mr, ldv, ldd, lq, lr : LONGINT ;
    neg : BOOLEAN ;
BEGIN
   k := rmReg ;
   CASE k OF
   | 0, 1 :                                  (* TEST r/m, imm *)
      IF w = 0 THEN src := Fetch8 () ELSE src := Fetch16 () END ;
      SetLogic (BAnd (RmRd (w), src, w), w)

   | 2 :                                     (* NOT: no flags at all *)
      res := BNot (RmRd (w), w) ;
      RmWr (res, w)

   | 3 :                                     (* NEG *)
      res := DoSub (0, RmRd (w), 0, w) ;
      RmWr (res, w)

   | 4 :                                     (* MUL, unsigned *)
      src := RmRd (w) ;
      IF w = 1 THEN
         prod := AX * src ;                  (* max 65535^2 < 2^32 *)
         DX := prod DIV 65536 ;
         AX := prod MOD 65536 ;
         res := AX
      ELSE
         (* MUL r8 writes only AX: AL*src, high byte in AH, DX untouched.
            It is easy to write DX := 0 here out of a false tidiness. *)
         prod := (AX MOD 256) * src ;
         AX := prod MOD 65536 ;
         res := AX
      END ;
      (* CF and OF are the documented ones for MUL; SF and ZF are
         architecturally undefined and are set from the low result rather
         than left alone, so that they are at least deterministic. *)
      IF w = 1 THEN
         CF := DX # 0
      ELSE
         CF := prod >= 256
      END ;
      OFl := CF ;
      SetZSF (res, w)

   | 5 :                                     (* IMUL, signed *)
      src := RmRd (w) ;
      IF w = 1 THEN
         ldd := S16 (AX) * S16 (src) ;
         lq := ldd
      ELSE
         ldd := S8 (AX MOD 256) * S8 (src) ;
         lq := ldd
      END ;
      (* The low word of a negative product is exactly lq MOD 65536, because
         ISO Modula-2's MOD always returns a non-negative remainder, which is
         the two's complement low word.  The high word is lq DIV 65536 for
         the same reason: DIV floors, which is an arithmetic shift. *)
      AX := VAL (CARDINAL, lq MOD VAL (LONGINT, 65536)) ;
      IF w = 1 THEN
         DX := VAL (CARDINAL, (lq DIV VAL (LONGINT, 65536))
                              MOD VAL (LONGINT, 65536)) ;
         CF := (lq < VAL (LONGINT, -32768))
               OR (lq > VAL (LONGINT, 32767)) ;
         res := AX
      ELSE
         CF := (lq < VAL (LONGINT, -128))
               OR (lq > VAL (LONGINT, 127)) ;
         res := AX
      END ;
      OFl := CF ;
      SetZSF (res, w)

   | 6 :                                     (* DIV, unsigned *)
      src := RmRd (w) ;
      IF src = 0 THEN
         Fault ("divide by zero")
      ELSE
         IF w = 1 THEN
            prod := DX * 65536 + AX ;
            q := prod DIV src ;
            remw := prod MOD src ;
            IF q > 65535 THEN
               Fault ("DIV: quotient does not fit in AX")
            ELSE
               AX := q ;
               DX := remw ;
               res := AX
            END
         ELSE
            prod := AX MOD 65536 ;
            q := prod DIV src ;
            remw := prod MOD src ;
            IF q > 255 THEN
               Fault ("DIV: quotient does not fit in AL")
            ELSE
               AX := remw * 256 + q ;
               res := q
            END
         END ;
         IF NOT isFault THEN
            CF := FALSE ;
            OFl := FALSE ;
            SetZSF (res, w)
         END
      END

   ELSE                                      (* /7 IDIV, signed *)
      src := RmRd (w) ;
      IF w = 1 THEN
         ldv := S16 (src) ;
         ldd := S16 (DX) * VAL (LONGINT, 65536) + VAL (LONGINT, AX)
      ELSE
         ldv := S8 (src) ;
         ldd := S8 (AX MOD 256)
      END ;
      IF ldv = VAL (LONGINT, 0) THEN
         Fault ("divide by zero")
      ELSE
         (* x86 IDIV truncates toward zero and gives the remainder the
            sign of the dividend.  ISO Modula-2's DIV/MOD are Euclidean:
            the remainder is always non-negative (measured: (-7) MOD 2 = 1,
            7 MOD (-2) = 1, (-7) DIV 2 = -4).  So the division is redone on
            magnitudes, where floor and truncation coincide, and the signs
            are put back afterwards. *)
         IF ldd < VAL (LONGINT, 0) THEN ma := VAL (LONGINT, 0) - ldd
         ELSE ma := ldd END ;
         IF ldv < VAL (LONGINT, 0) THEN mb := VAL (LONGINT, 0) - ldv
         ELSE mb := ldv END ;
         mq := ma DIV mb ;
         mr := ma MOD mb ;
         neg := (ldd < VAL (LONGINT, 0)) # (ldv < VAL (LONGINT, 0)) ;
         IF neg THEN lq := VAL (LONGINT, 0) - mq ELSE lq := mq END ;
         IF ldd < VAL (LONGINT, 0) THEN lr := VAL (LONGINT, 0) - mr
         ELSE lr := mr END ;

         IF w = 1 THEN
            IF (lq < VAL (LONGINT, -32768)) OR (lq > VAL (LONGINT, 32767)) THEN
               Fault ("IDIV: quotient does not fit in AX")
            ELSE
               AX := VAL (CARDINAL, lq MOD VAL (LONGINT, 65536)) ;
               DX := VAL (CARDINAL, lr MOD VAL (LONGINT, 65536)) ;
               SetZSF (AX, 1)
            END
         ELSE
            IF (lq < VAL (LONGINT, -128)) OR (lq > VAL (LONGINT, 127)) THEN
               Fault ("IDIV: quotient does not fit in AL")
            ELSE
               (* IDIV r8 also overwrites both halves: AL := quotient,
                  AH := remainder, so the old AH is gone. *)
               AX := VAL (CARDINAL, lr MOD VAL (LONGINT, 256)) * 256
                    + VAL (CARDINAL, lq MOD VAL (LONGINT, 256)) ;
               SetZSF (VAL (CARDINAL, lq MOD VAL (LONGINT, 256)), 0)
            END
         END ;
         IF NOT isFault THEN
            CF := FALSE ;
            OFl := FALSE
         END
      END
   END
END DoUnaryGroup ;


(* --------------------------------------------------------- FF group (word) *)

PROCEDURE DoFFGroup ;
(* FF, after DoModRM has run with w = 1. *)
VAR k, res : CARDINAL ;
    cfSave : BOOLEAN ;
BEGIN
   k := rmReg ;
   CASE k OF
   | 0 :                                     (* INC r/m: CF is preserved *)
      cfSave := CF ;
      res := DoAdd (RmRd (1), 1, 0, 1) ;
      CF := cfSave ;
      RmWr (res, 1)
   | 1 :                                     (* DEC r/m: CF is preserved *)
      cfSave := CF ;
      res := DoSub (RmRd (1), 1, 0, 1) ;
      CF := cfSave ;
      RmWr (res, 1)
   | 2 :                                     (* CALL near r/m *)
      Push (IP) ;
      IP := RmRd (1)
   | 4 :                                     (* JMP near r/m *)
      IP := RmRd (1)
   | 6 :                                     (* PUSH r/m *)
      Push (RmRd (1))
   ELSE
      Fault ("unsupported opcode in the FF group (far call/jump)")
   END
END DoFFGroup ;


(* ----------------------------------------------------------- one instruction *)

PROCEDURE Step ;
VAR op, w, f, alu, v, d, imm, res, n, k : CARDINAL ;
    cfSave : BOOLEAN ;
BEGIN
   faultIP := IP ;                           (* what to report if we fault *)
   op := Fetch8 () ;

   IF (op = 06H) OR (op = 0EH) OR (op = 16H) OR (op = 1EH) THEN
      (* PUSH ES / CS / SS / DS.  CS and SS are pushed by nothing in the
         corpus, but the four encodings are one instruction apart and
         leaving two of them out would be a gap nobody could explain. *)
      IF op = 06H THEN Push (ES)
      ELSIF op = 0EH THEN Push (CS)
      ELSIF op = 16H THEN Push (SS)
      ELSE Push (DS)
      END

   ELSIF (op = 07H) OR (op = 17H) OR (op = 1FH) THEN
      IF op = 07H THEN ES := Pop ()
      ELSIF op = 17H THEN SS := Pop ()
      ELSE DS := Pop ()
      END

   ELSIF (op = 26H) OR (op = 2EH) OR (op = 36H) OR (op = 3EH) THEN
      Fault ("segment override prefix: this interpreter is 64 KB flat")

   ELSIF op < 40H THEN
      (* The 00-3D family: eight ALU operations in six encodings each.
         `alu' is the group number, `f' the form.
            f = 0,1  op r/m, r        f = 2,3  op r, r/m
            f = 4    op AL, imm8      f = 5    op AX, imm16
         f = 6,7 are the prefixes and DAA/DAS/AAA/AAS, all consumed above
         or unreachable, so reaching here is a real unknown. *)
      alu := (op DIV 8) MOD 8 ;
      f := op MOD 8 ;
      IF f <= 3 THEN
         w := f MOD 2 ;
         DoModRM (w) ;
         IF f <= 1 THEN
            res := Alu (alu, RmRd (w), GetReg (rmReg, w), w) ;
            IF alu # 7 THEN RmWr (res, w) END
         ELSE
            res := Alu (alu, GetReg (rmReg, w), RmRd (w), w) ;
            IF alu # 7 THEN PutReg (rmReg, w, res) END
         END
      ELSIF f = 4 THEN
         v := Fetch8 () ;
         res := Alu (alu, AX MOD 256, v, 0) ;
         IF alu # 7 THEN PutReg (0, 0, res) END
      ELSIF f = 5 THEN
         v := Fetch16 () ;
         res := Alu (alu, AX, v, 1) ;
         IF alu # 7 THEN PutReg (0, 1, res) END
      ELSE
         Fault ("unknown opcode in the ALU family")
      END

   ELSIF op < 50H THEN
      (* INC r16 / DEC r16.  These do NOT affect CF, which is easy to lose:
         going through DoAdd sets it, so it is saved and restored. *)
      k := op - 40H ;
      cfSave := CF ;
      IF k < 8 THEN
         res := DoAdd (GetReg (k, 1), 1, 0, 1) ;
         PutReg (k, 1, res)
      ELSE
         res := DoSub (GetReg (k - 8, 1), 1, 0, 1) ;
         PutReg (k - 8, 1, res)
      END ;
      CF := cfSave

   ELSIF op < 60H THEN
      IF op < 58H THEN
         Push (GetReg (op - 50H, 1))
      ELSE
         PutReg (op - 58H, 1, Pop ())
      END

   ELSIF op < 70H THEN
      Fault ("opcode not implemented (60H-6FH is 80186 and later)")

   ELSIF op < 80H THEN
      d := Fetch8 () ;
      IF Cond (op - 70H) THEN
         IP := (IP + SE8 (d)) MOD 65536
      END

   ELSIF (op = 80H) OR (op = 81H) OR (op = 83H) THEN
      IF op = 80H THEN w := 0 ELSE w := 1 END ;
      DoModRM (w) ;
      k := rmReg ;
      IF op = 83H THEN
         imm := SE8 (Fetch8 ())             (* sign-extended to the full width *)
      ELSIF w = 0 THEN
         imm := Fetch8 ()
      ELSE
         imm := Fetch16 ()
      END ;
      res := Alu (k, RmRd (w), imm, w) ;
      IF k # 7 THEN RmWr (res, w) END

   ELSIF (op = 84H) OR (op = 85H) THEN
      (* TEST r/m, r.  Same AND and same flag rule as F6/F7 /0; only the
         encoding differs, and leaving it out while having the other one
         would be a gap with no reason behind it. *)
      w := op - 84H ;
      DoModRM (w) ;
      SetLogic (BAnd (RmRd (w), GetReg (rmReg, w), w), w)

   ELSIF (op = 86H) OR (op = 87H) THEN
      w := op - 86H ;
      DoModRM (w) ;
      v := RmRd (w) ;
      RmWr (GetReg (rmReg, w), w) ;
      PutReg (rmReg, w, v)

   ELSIF (op >= 88H) AND (op <= 8BH) THEN
      w := op MOD 2 ;
      DoModRM (w) ;
      IF op >= 8AH THEN
         PutReg (rmReg, w, RmRd (w))
      ELSE
         RmWr (GetReg (rmReg, w), w)
      END

   ELSIF (op = 0C6H) OR (op = 0C7H) THEN
      (* MOV r/m,imm.  The compiler emits C6 06 lo hi imm for the CRT
         attribute byte; C7 is the 16-bit form.  The ModRM reg field is
         reserved (must be 0) and a register destination is not this opcode
         (8A/8B or B0+/B8+ are). *)
      w := op - 0C6H ;
      DoModRM (w) ;
      IF eaIsReg THEN
         Fault ("MOV r/m,imm needs a memory destination")
      ELSE
         IF w = 0 THEN
            v := Fetch8 ()
         ELSE
            v := Fetch16 ()
         END ;
         RmWr (v, w)
      END

   ELSIF op = 8DH THEN
      DoModRM (1) ;
      IF eaIsReg THEN
         Fault ("LEA with a register operand is not an address")
      ELSE
         PutReg (rmReg, 1, eaAddr)
      END

   ELSIF (op >= 90H) AND (op <= 97H) THEN
      k := op - 90H ;
      IF k # 0 THEN                          (* 90 is NOP *)
         v := AX ;
         AX := GetReg (k, 1) ;
         PutReg (k, 1, v)
      END

   ELSIF op = 98H THEN                       (* CBW: sign-extend AL into AX *)
      IF (AX MOD 256) >= 80H THEN
         AX := 65280 + (AX MOD 256)
      ELSE
         AX := AX MOD 256
      END

   ELSIF op = 99H THEN                       (* CWD: sign-extend AX into DX *)
      IF AX >= 8000H THEN DX := 0FFFFH ELSE DX := 0 END

   ELSIF (op >= 0A0H) AND (op <= 0A3H) THEN
      d := Fetch16 () ;                      (* moffs: DS is 0, checked in Run86 *)
      CASE op OF
      | 0A0H : AX := (AX DIV 256) * 256 + mem [d]
      | 0A1H : AX := mem [d] + 256 * mem [(d + 1) MOD 65536]
      | 0A2H : mem [d] := AX MOD 256
      ELSE     mem [d] := AX MOD 256 ;
               mem [(d + 1) MOD 65536] := (AX DIV 256) MOD 256
      END

   ELSIF (op >= 0B0H) AND (op <= 0BFH) THEN
      IF op < 0B8H THEN
         PutReg (op - 0B0H, 0, Fetch8 ())
      ELSE
         PutReg (op - 0B8H, 1, Fetch16 ())
      END

   ELSIF op = 0C3H THEN                      (* RET *)
      IP := Pop ()

   ELSIF op = 0C9H THEN                      (* LEAVE: SP := BP; BP := POP *)
      SP := BP ;
      BP := Pop ()

   ELSIF op = 0CDH THEN                      (* INT *)
      n := Fetch8 () ;
      IF n = 21H THEN
         DoInt21 ()
      ELSIF n = 10H THEN
         DoInt10 ()
      ELSE
         Fault ("only INT 21h and INT 10h are provided; this is not a real-mode machine")
      END

   ELSIF op = 0E2H THEN                      (* LOOP: CX is not a flag *)
      d := Fetch8 () ;
      CX := (CX + 65535) MOD 65536 ;
      IF CX # 0 THEN
         IP := (IP + SE8 (d)) MOD 65536
      END

   ELSIF op = 0E3H THEN                      (* JCXZ *)
      d := Fetch8 () ;
      IF CX = 0 THEN
         IP := (IP + SE8 (d)) MOD 65536
      END

   ELSIF op = 0E8H THEN                      (* CALL rel16 *)
      d := Fetch16 () ;
      Push (IP) ;
      IP := (IP + d) MOD 65536

   ELSIF op = 0E9H THEN                      (* JMP rel16 *)
      d := Fetch16 () ;
      IP := (IP + d) MOD 65536

   ELSIF op = 0EBH THEN                      (* JMP rel8 *)
      d := Fetch8 () ;
      IP := (IP + SE8 (d)) MOD 65536

   ELSIF (op = 0F6H) OR (op = 0F7H) THEN
      DoModRM (op - 0F6H) ;
      DoUnaryGroup (op - 0F6H)

   ELSIF op = 0FFH THEN
      DoModRM (1) ;
      DoFFGroup

   ELSE
      WrS ("exec86: unknown opcode ") ;
      WrHex (op) ;
      WrS (" at ") ;
      WrHex (faultIP) ;
      WrErr1 (CHR (10)) ;
      Fault ("unknown opcode")
   END
END Step ;


(* ------------------------------------------------------------------ public *)

PROCEDURE Clear86 ;
VAR i : CARDINAL ;
BEGIN
   FOR i := 0 TO 65535 DO
      mem [i] := 0
   END ;
   AX := 0 ; BX := 0 ; CX := 0 ; DX := 0 ;
   SI := 0 ; DI := 0 ; BP := 0 ;
   SP := 0FFFEH ;                            (* bootcom's SS:SP = 0000:FFFE *)
   CS := 0 ; DS := 0 ; ES := 0 ; SS := 0 ;
   IP := LoadAt ;                            (* bootcom's JMP 0000:0100 *)
   CF := FALSE ; ZF := FALSE ; SF := FALSE ; OFl := FALSE ;
   halted := FALSE ;
   haltCode := 0 ;
   isFault := FALSE ;
   faultIP := LoadAt ;
   loadHi := LoadAt ;
   stepCnt := 0 ;
   eaAddr := 0 ; eaReg := 0 ; eaIsReg := FALSE ; rmReg := 0
END Clear86 ;

PROCEDURE Poke86 (addr, value : CARDINAL) ;
BEGIN
   IF addr > 65535 THEN
      faultIP := IP ;
      Fault ("Poke address is outside the 64 KB machine")
   ELSE
      mem [addr] := value MOD 256 ;
      IF addr >= loadHi THEN
         loadHi := addr + 1
      END
   END
END Poke86 ;

PROCEDURE Run86 (VAR exitCode : CARDINAL; VAR steps : LONGCARD) : CARDINAL ;
VAR cap : LONGCARD ;
BEGIN
   exitCode := 0 ;
   steps := 0 ;
   isFault := FALSE ;
   halted := FALSE ;
   cap := VAL (LONGCARD, MaxSteps) ;
   LOOP
      IF halted THEN
         exitCode := haltCode ;
         steps := stepCnt ;
         RETURN 0
      END ;
      IF isFault THEN
         steps := stepCnt ;
         RETURN 1
      END ;
      IF stepCnt >= cap THEN
         faultIP := IP ;
         WrS ("exec86: step limit ") ;
         WrDec (MaxSteps) ;                  (* runaway guard, Exec86.def *)
         WrS (" reached at IP=") ;
         WrHex (IP) ;
         WrErr1 (CHR (10)) ;
         steps := stepCnt ;
         RETURN 2
      END ;
      (* Checked before every step, not once at the start: the machine is
         64 KB flat, so a non-zero segment would silently alias onto the
         same memory instead of faulting. *)
      IF (CS # 0) OR (DS # 0) OR (ES # 0) OR (SS # 0) THEN
         faultIP := IP ;
         Fault ("a segment register is not zero; this machine is 64 KB flat") ;
         steps := stepCnt ;
         RETURN 1
      END ;
      IF (IP < LoadAt) OR (IP >= loadHi) THEN
         faultIP := IP ;
         Fault ("execution left the loaded image") ;
         steps := stepCnt ;
         RETURN 1
      END ;
      Step () ;
      stepCnt := stepCnt + 1
   END
END Run86 ;

END Exec86.