Date: Monday, June 6, 1994
From: mheiskan@hut.fi [Mika Heiskanen]
  Re: Fast replacement for the ORDER command (SX&GX)

--> S/SX/G/GX

[Note: The HACK library (also on this disk) contains an ORD command,
 which is basically the same as the following.  But if you don't want
 to load the whole HACK library just for ORD, here it is all by
 itself.  -jkh-]

**********************************************************************
* Name:ORD
* Stack:( {names} --> )   [or a single name, not in a list.  -jkh-]
* Description:Replacement for slow HP ORDER
*
* Timing samples for <-LIB-> after L->DIR (~80 variables, SX)
*
*                               HP      ORD
*       Reversing order:        124s    6.8s
*       Redundant:              117s    1.4s
*
* The redundant case changes the order of the last 2 variables only
**********************************************************************

ASSEMBLE
=SETNONEXTERR EQU #18C92 *
=DoHere: EQU #185C7 *
=REFERENCED? EQU #065E5 *
=MOVERRP EQU #21074 *
*
=IRAM@ EQU #0011F *
=IRAMBUFF EQU #700F1 * V
=G_IRAMBUFF EQU #800F5 * V
=INITEN EQU #704DB * V
=G_INITEN EQU #8065A * V
=aCONTEXT EQU #08D61 *
*
=chk_attn EQU #04988 *
=FNDLOPTR EQU #08503 *
=PTRADJUST2 EQU #0686E *
=TRAVERSE+ EQU #08400 *
=TRAVERSE- EQU #0841E *
=S_FIND EQU #078C6 * V
=G_FIND EQU #07891 * V
*
sGX EQU 8 GX ?
fUSEIRAM EQU 1 Use IRAM in BLKSWAP?
fCKPORT EQU 2 Check that context isn't in a port?
SETFLAG fUSEIRAM Yes
RPL
::
  CK1NOLASTWD
  :: CK&DISPATCH0
     FIVE NOP
     SIX  ONE{}N ( Allow idnt as arg too )
  ;

* First handle the new lastram-word

  DUP CARCOMP
  DUPTYPEIDNT? ?SKIP SETTYPEERR ( Error if not idnt )
  DoHere: DUP@ ?SKIP SETNONEXTERR ( Error if not variable )
* ( {ids} id1 ob1 )
  DUPTYPERRP? ( --> {} id ob rrp? )
  SWAP REFERENCED? ( --> {} id rrp? ob ref? )
  ROTAND ITE
    MOVERRP
    :: OVER PURGE SWAP CREATE ;
* ( {ids} )

* The code cannot order itself
* Make a copy of code to tempob if necessary
* (Could do it always to save a couple nibbles..)

  CODE
  GOSBVL=SAVPTR
  GOSUB GETRRP&LAST B[A]=->context C[A]=->lastram-name
  D0=C
  GOSBVL=TRAVERSE+ D0 = ->lastram-word
  GOSBVL=SKIPOB
  CD0EX C[A] = ->contexttail
  A=PC
  ?A<B A pc < context ?
  GOYES in100
  ?A>C A pc > contexttail ?
  GOYES in100
in100 GOVLNG =GPPushT/FLp Push F if in context
  ENDCODE

  ?SKIP :: 'R TOTEMPOB EVAL ; ( Evaluate code from tempob )

  ( Normal evaluate )

* Each slot in userob is:
*
*  [Name][Object][Link]
*
* Moving the variable to upper userob:
*
*  Start:[Name1][Ob1][Link1][Name2]..[NameN][ObN][LinkN]
*  End:[Name2][Ob2]..[NameN][ObN][LinkN][Name1][Ob1][Link1]
*
*= Swap blocks: ->Name1 ->Name2 ->LinkN+5
*
* If someone would like to implement it all in ml:
*
* Moving the variable to lastram-word:
*
*  Start:[Off]...[Name1][Ob1][Link1][Name2]..[LinkL][NameN][ObN][Extra5]
*  End:[Off']..[Name2][Ob2]..[NameN][ObN][Extra5][Name1][Ob1][Link1]
*
*= Fix:Replace Link1 with Extra5 before swap
*  Replace Extra5 with LinkN before swap
*  Off = Off + LinkN - Link1 before swap
*= Swap blocks:->Name1 ->Name2 ->ObNtail+5
* Note that the extra 5 nibbles may be referenced. Thus the PTRADJUST2 call
* must use the correct endaddress of the context.
*

CODE
* R0 & R1 used by BLKSWAP
* R2 free
* R3[A] = ->idnt (sequence)
* R4[A] = ->next tail address

* Setup idnt list
  GOSBVL =PopASavptr
  A=A+CON A,10
  R3=A R3[A] = ->idnt1_body

* Setup next free location

  GOSUB GETRRP&LAST B[A]= ->context C[A]= ->last-ramname
  R4=C R4[A] = ->lastram-name

  GOSUB SETSXGXSetup sGX

* Disable ON-C
  LC(1) #F
  GOSUB SETINITEN

* Note! 1st idnt has already been handled so skipob starts the loop

ORDERLOOP GOSBVL=chk_attn
  GOC ORDEREXIT
  A=R3
  D0=A D0 = ->idnt_body
  D0=D0-5
  GOSBVL =SKIPOB
  A=DAT0 A
  LC(5) =SEMI
  ?A=C A
  GOYES ORDEREXIT Found SEMI - done
  LC(4) =DOIDNT
  ?A#C A
  GOYES ORDERERR Not id! Error
  D0=D0+5
  AD0EX
  R3=A R3[A] = ->idnt_body
  R0=A * For FIND
  GOSUB GETCONTEXT A[A] = ->context
  GOSUB FIND D0 = ->Ob1 D[A] = ->Name1
  GOC ORDER ERR Not variable! Error
  GOSBVL =SKIPOB
  D0=D0+5
  C=D A
  CD0EX D0 = ->Name1C[A] = ->Name2
  D1=C D1 = ->Name2
  A=R4 A[A] = ->next
  ?C>=A A Special case?
  GOYES ORDERSPC
  C=A-C A C[A] = nibbles2 = next-Name2
* Also update ->next to be ->Name1 + nibbles2
  AD0EX A[A] = ->Name1
  D0=A
  A=A+C A
  R4=A.F A R4[A] = ->next'
  GOSUB BLKSWAP+
  GOTO ORDERLOOP

ORDEREXIT C=0 P
  GOSUB SETINITEN Enable ON-C
  GOVLNG =GETPTRLOOP
ORDERERR GOSBVL =GETPTR
  GOVLNG (=SYNTAXERR)+5

* Special cases:
* 1) Variable is already at it's final location
*  Then->Name2 = ->next
*  Solution: set ->next = ->Name1 & continue
* 2) Duplicate ids in the list
*  Then->Name1 > ->next
*  Assuming above check is already made then ->Name2 > ->next
*  Solution: keep ->next the same & continue

ORDERSPC ?C#A->Name2 <> ->next?
  GOYES sp100 Yes - duplicate idnt, keep ->next
  AD0EX Already at right place..
  R4=A Set ->next = ->Name1
sp100 GOTO ORDERLOOP

****************************************
FIND ?ST=1 sGX
  GOYES ff100
  GOVLNG =S_FIND D0 = ->Ob  D[A]=->Name
ff100 GOVLNG =G_FIND CS if not found
****************************************
GETRRP&LAST GOSUB GETCONTEXT
  B=A A B[A] = ->context
  GOSBVL =FNDLOPTR
  A=DAT0 A A[A] = offset
  CD0EX
  C=C+A A C[A] = ->last-ramname
  RTN
****************************************
GETCONTEXT D0=(5) =aCONTEXT
  A=DAT0 A
  D0=A
  A=DAT0 A
  RTN
****************************************
SETINITEN D0=(5) =INITEN
  ?ST=0 sGX
  GOYES si100
  D0=(5) =G_INITEN
si100 DAT0=C 1
  RTN
**********************************************************************
SETSXGX ST=0 sGX Assume SX
  D0=(5) =IRAM@
  A=DAT0 S 7 for S, 8 for G
  A=A+A S
  RTNNC
  ST=1 sGX Set GX
  RTN
**********************************************************************
* Swap contiguous memory blocks in place.
* Entry:D0= ->block1(lower)
*  D1= ->block2(higher)
*  C[A]= size of block2
* Alters:A[W] C[W] B[A] D[A]
* Stack:1 (BLKswap)
* 
* Performance can be poor if one of the blocks is small.
* Setting compiler flag fUSEIRAM enables special code when either
* block is smaller than #100 nibbles. IRAMBUFF is then used as a buffer
* for the smaller block to do a buffered block swap.
*
**********************************************************************

* PTRADJUST2:
* Entry:A[A]= ->block1B[A]= ->block1tailC[A]= offs1
* R0[A]= ->block2R1[A]= ->block2tailD0= offs2
* Exit:
*  All same as entry except C[A] moved to D[A]
* Uses:
*  D1 C[15-14]
* Applied:
* Entry:A[A]= ->block1B[A]= ->block2C[A]= nibbles2
*  R0[A]= ->block2R1[A]= ->block2tailD0= -nibbles1

BLKSWAP+ ?C=0 A
  RTNYES
  AD1EX
  B=A A B[A] = ->block2
  R0=A R0[A] = ->block2
  RSTK=C
  C=C+A A
  R1=C R1[A] = ->block2tail
  AD0EX A[A] = ->block1
  C=R0
  C=C-A A
  C=-C A
  D0=C D0 = -nibbles1
  C=RSTK C[A] = nibbles2
  GOSBVL =PTRADJUST2
* Restore entry conditions for BLKSWAP
  D0=A D0 = ->block1
  A=B A
  D1=A D1 = ->block2
  C=D A C[A] = nibbles2

BLKSWAP B=C A B[A] = nibbles2 during loop
BLKswaplp ?B=0 A * Done if nibbles2 = 0
  RTNYES
  AD0EX
  D0=A
  CD1EX
  D1=C
  C=C-A A C[A] = nibbles1
  ?C=0 A * Done if nibbles1 = 0
  RTNYES
  ?C>=B A * nibbles1 >= nibbles2 ?
  GOYES BLKup&back * Swap block & D1 comes back
  IF fUSEIRAM
    A=C A
    A=0 B
    ?A=0 A
    GOYES BLKiram1 * Use IRAM if nibbles1 < #100
  ENDIF
  B=B-C A * Block 2 becomes smaller
  GOSUB BLKswap * swap blocks of size nibbles1
  GONC BLKswaplp

BLKup&back
  IF fUSEIRAM
    A=B A
    A=0 B
    ?A=0 A
    GOYESBLK iram2 * Use IRAM if nibbles2 < #100
  ENDIF
  C=B A * nibbles2
  GOSUB BLKswap
  CD1EX * D1 back to where it was
  C=C-B A
  CD1EX
  GONC BLKswaplp

  IF fUSEIRAM

* nibbles1 < #100. block1 to IRAM, block2 down, block1 to end
BLKiram1 R0=C R0[A] = nibbles1
    CD0EX
    R1=C R1[A] = ->block1
    D0=C
    GOSUB GETIRAM
    D1=C
    C=R0
    GOSBVL =MOVEDOWN Buffered block1, D0 = ->block2
    A=R1
    D1=A D1 = ->block1
    C=B A C[A] = nibbles2
    GOSBVL =MOVEDOWN D1 = ->block2tail'
    GOSUB GETIRAM
    D0=C
    C=R0 C[A] = nibbles1
    GOVLNG =MOVEDOWN

* nibbles2 < #100. block2 to IRAM, block1 up, block2 to bottom
BLKiram2 R0=C R0[A] = nibbles1
    CD1EX
    R1=C R1[A] = ->block2
    D0=C D0 = ->block2
    GOSUB GETIRAM
    D1=C
    C=B A C[A] = nibbles2
    GOSBVL =MOVEDOWN D0 = ->block2tail
    C=R1
    CD0EX D0 = ->block2
    D1=C D1 = ->block2tail = ->block1tail'
    C=R0
    GOSBVL =MOVEUP D0 = ->block1
    GOSUB GETIRAM
    CD0EX D0 = ->buffer
    D1=C D1 = ->block1
    C=B A C[A] = nibbles2
    GOVLNG =MOVEDOWN

GETIRAM LC(5) =IRAMBUFF
    ?ST=0 sGX
    RTNYES
    LC(5) =G_IRAMBUFF
    RTN
  ENDIF

**********************************************************************
* Swap equal size blocks
* Entry:D0= ->blk1D1= ->blk2C[A]= nibbles
* Exit:D0= ->blk1 tailD1= ->blk2 tailCC
* Alters:A[W] C[W] D[A] P CRY
**********************************************************************
BLKswap C=C-1 A
  GOC BLKupdone * Nothing to swap
  P=C 0 * P=nibs
  CSR A * C[A]=words
  D=C A
  D=D-1 A
  GOC BLKupwrd * Swap the last <= 16 nibbles

BLKuplp A=DAT0 W * Modified MOVEDOWN code
  C=DAT1 W
  DAT0=C W
  DAT1=A W
  D0=D0+ 16
  D1=D1+ 16
  D=D-1 B
  GONC BLKuplp
  D=D-1 XS
  GONC BLKuplp
  D=D+1 X
  D=D-1 A
  GONC BLKuplp * Better not forget this..

BLKupwrd A=DAT0 WP
  C=DAT1 WP
  DAT0=C WP
  DAT1=A WP
  CD0EX
  C+P+1
  D0=C
  CD1EX
  C+P+1
  D1=C
BLKupdone P=0
  RTNCC
**********************************************************************
ENDCODE

;
--
--->Mika Heiskanen, mheiskan@delta.hut.fi