// IfsOvXMInit.bcpl - Initialization for Bcpl code in Extended Memory
// Copyright Xerox Corporation 1979, 1980, 1981, 1982

// Last modified September 17, 1982  1:21 PM by Taft

get "AltoFileSys.d"
get "Disks.d"
get "Ifs.decl"
get "IfsInit.decl"
get "IfsVMem.decl"
get "IfsXEmulator.decl"
get "IfsOverlays.decl"
get "SysDefs.d"
get "AltoDefs.d"
get "BTree.decl"

external
[
// Outgoing procedures
InitXMOverlays

// Incoming procedures
Allocate; DoubleBlt; Enqueue; Free; Usc; MoveBlock; Max; Min; SysErr
GenerateOverlays; IFSError; OverlayFirstPn; OverlayNpages; ReadOverlay;
LoadXM; StoreXM; @VRRP; LockCell
IFSAllocate; IFSFree; Idle; IFSIdle
TFSActOnPages; TFSVirtualDA;
TFSInitializeCbStorage; TFSDoDiskCommand; TFSGetCb
OvDOPAGEIO; OvCleanupLocks; OvPageType; OvPageGroupBase; OvPageGroupAlign;
OvPageGroupSize; DeclareOverlayPresent;
NoBufsProc; LockedCells; LastLockedCell; OverlayLockProc
BVRRP; BVWRP; BtLockCell; BtUnlockCell
VFileDOPAGEIO; VFilePageType; VFilePageGroupBase; VFilePageGroupAlign;
VFilePageGroupSize

// Incoming statics
numOvXMPages; numOvXMPagesPerBank; offsetResidentXM;
ovFirstPage; ovPageSize; logOvPageSize; logOvVmPages
FirstOEP; EndOEP; FirstOD; EndOD; oVmd; vFileVMI
sysZone; bigZone; smallZone; AltoVersion; isb; primaryIFS
]

manifest
[
jsrRv370=#6370; sta312=#55001; jsrRv367=#6367; jsrRv366=#6366;

ecIllFormedXMOverlay = 50
ecOverlayCrossesBank = 51
]

structure ZN:  // Zone structure, copied from Alloc.bcpl
[
Allocate word
Free word
OutOfSpaceRtn word
MalformedRtn word
]

//----------------------------------------------------------------------------
let InitXMOverlays() = valof
//----------------------------------------------------------------------------
// Called during swappable initialization to load as many overlays as will
// fit into extended memory, if present.  Returns true if at least one
// extended memory bank is present and false otherwise.
// Consumes storage starting at isb>>ISB.initStart for creating XJmp blocks,
// and updates the initStart cell.
[
// Swap in and lock any pinned overlays (for debugging)
for i = 0 to (size ISB.pinnedOverlays/16)-1 do
   if isb>>ISB.pinnedOverlays↑i ne 0 then
      [
      let od = FirstOD + (isb>>ISB.pinnedOverlays↑i -1)*lOD
      if od>>OD.core eq 0 then
         DeclareOverlayPresent(od,
          VRRP((OverlayFirstPn(od)-ovFirstPage) lshift logOvVmPages +
          oVmd>>VMD.base))
      LockCell(lv od>>OD.core)
      ]

let nBanks = Min(CountBanks(), isb>>ISB.maxBanksXM)
if nBanks le 1 resultis false

// Must not cause an overlay fault during the following, since the overlay
// fault handler might try to get the overlay from XM!
numOvXMPagesPerBank = 177000b rshift logOvPageSize
numOvXMPages = numOvXMPagesPerBank*(nBanks-1)
GenerateOverlays(LoadOverlayIntoXM)

// See if there is enough XM left over to load all the resident Bcpl code,
// which begins at layout vector PC value "X" and ends at value "I".
let baseResident = isb>>ISB.pcX & -2  // make even (for DoubleBlt)
let endResident = isb>>ISB.pcI
let residentXMPages = (endResident-baseResident-1) rshift logOvPageSize +1
let numXMPagesUsed = OverlayFirstPn(EndOD) - ovFirstPage
if numXMPagesUsed + residentXMPages le numOvXMPages then
   [
   // Decide where to put it so as not to cross a bank boundary
   let page = numXMPagesUsed rem numOvXMPagesPerBank
   let bank = numXMPagesUsed/numOvXMPagesPerBank +1
   if page+residentXMPages gr numOvXMPagesPerBank then
      [ page = 0; bank = bank+1 ]  // start in next higher bank

   // Copy the code into XM
   let baseXM = page lshift logOvPageSize
   offsetResidentXM = baseXM - baseResident
   DoubleBlt(baseXM, baseResident, residentXMPages lshift logOvPageSize,
    bank lshift 2)

   // Create XJMP blocks for all the procedures, and fix up their statics
   let oldOverlayLockProc = OverlayLockProc
   let relocTable = isb>>ISB.relocTable
   for i = 1 to relocTable!0 do
      [
      let pStatic = relocTable!i
      if @pStatic uls endResident then
         [  // in resident XM code, as opposed to init
         let xjmp = isb>>ISB.initStart; isb>>ISB.initStart = xjmp+2
         xjmp!0 = XJMP0 + bank
         xjmp!1 = @pStatic + offsetResidentXM
         // When we find the rAllocate and rFree procedures (which aren't
         // declared external), fix up the values in smallZone and bigZone.
         if @pStatic eq smallZone>>ZN.Allocate then
            [ smallZone>>ZN.Allocate = xjmp; bigZone>>ZN.Allocate = xjmp ]
         if @pStatic eq smallZone>>ZN.Free then
            [ smallZone>>ZN.Free = xjmp; bigZone>>ZN.Free = xjmp ]
         @pStatic = xjmp
         ]
      ]

// InitXMOverlays (cont'd)

   // Fix up procedure values in existing disk, zone, tree, vmi objects
   for i = 0 to primaryIFS>>IFS.numUnits-1 do
      [
      let disk = primaryIFS>>IFS.lpdt↑i
      disk>>DSK.ActOnDiskPages = TFSActOnPages
      disk>>DSK.VirtualDiskDA = TFSVirtualDA
      disk>>DSK.InitializeDiskCBZ = TFSInitializeCbStorage
      disk>>DSK.DoDiskCommand = TFSDoDiskCommand
      disk>>DSK.GetDiskCb = TFSGetCb
      ]
   sysZone>>ZN.Allocate = IFSAllocate; sysZone>>ZN.Free = IFSFree
   smallZone>>ZN.OutOfSpaceRtn = SysErr
   if smallZone>>ZN.MalformedRtn ne 0 then smallZone>>ZN.MalformedRtn = SysErr
   bigZone>>ZN.OutOfSpaceRtn = SysErr
   if bigZone>>ZN.MalformedRtn ne 0 then bigZone>>ZN.MalformedRtn = SysErr
   let tree = primaryIFS>>IFS.dirBTree
   tree>>TREE.BVRRP = BVRRP; tree>>TREE.BVWRP = BVWRP
   tree>>TREE.BLockCell = BtLockCell; tree>>TREE.BUnlockCell = BtUnlockCell
   vFileVMI>>VMI.DOPAGEIO = VFileDOPAGEIO
   vFileVMI>>VMI.PageType = VFilePageType
   vFileVMI>>VMI.PageGroupBase = VFilePageGroupBase
   vFileVMI>>VMI.PageGroupAlign = VFilePageGroupAlign
   vFileVMI>>VMI.PageGroupSize = VFilePageGroupSize
   let oVmi = oVmd>>VMD.vmi
   oVmi>>VMI.DOPAGEIO = OvDOPAGEIO
   oVmi>>VMI.CleanupLocks = OvCleanupLocks
   oVmi>>VMI.PageType = OvPageType
   oVmi>>VMI.PageGroupBase = OvPageGroupBase
   oVmi>>VMI.PageGroupAlign = OvPageGroupAlign
   oVmi>>VMI.PageGroupSize = OvPageGroupSize

   // Fix up other copies of procedure statics
   Idle = IFSIdle
   let lc = LockedCells; while lc ne LastLockedCell do
      [ if lc!1 eq oldOverlayLockProc then lc!1 = OverlayLockProc; lc = lc+2 ]
   isb>>ISB.residentCodeXM = true  // tell InitIFSPart3 we did this
   ]
resultis true
]

//----------------------------------------------------------------------------
and LoadOverlayIntoXM(od) be
//----------------------------------------------------------------------------
[
let ovn = (od-FirstOD)/lOD +1
for i = 0 to (size ISB.pinnedOverlays/16)-1 do
   if isb>>ISB.pinnedOverlays↑i eq ovn then return // pinned overlay

let normPage = OverlayFirstPn(od)-ovFirstPage
let nPages = OverlayNpages(od)
if normPage+nPages le numOvXMPages then
   [
   // Overlay will fit in XM.  Read it in so we can play with it.
   let page = normPage rem numOvXMPagesPerBank
   let bank = normPage/numOvXMPagesPerBank +1
   let xBase = page lshift logOvPageSize
   if page+nPages gr numOvXMPagesPerBank then IFSError(ecOverlayCrossesBank)
   let buf = Allocate(sysZone, nPages lshift logOvPageSize)
   ReadOverlay(ovFirstPage+normPage, buf, nPages)

   // Sort the Bcpl pairs by relative PC value.
   let firstPair = buf + #21 + buf!1;
   let lastPair = firstPair + 2 * firstPair!-1 - 2;
   for sortPair = firstPair + 2 to lastPair by 2 do  // bubble sort the pairs
      [
      let staticAddress = sortPair!0; let relativePC = sortPair!1;
      for pair = sortPair - 2 to firstPair by -2 do
         [
         if relativePC ugr pair!1 then break;
         pair!2 = pair!0; pair!3 = pair!1;
         pair!0 = staticAddress; pair!1 = relativePC;
         ] 
      ]

   // Move the non-Bcpl pairs to the beginning of the relocation pair table.
   // A Bcpl pair is one that points to a Bcpl entry sequence or that is
   // bracketed by a Bcpl entry and a Bcpl return (i.e., a label).
   // We know that the compiler generates only one Bcpl return per procedure,
   // and it is always at the end.  Watch out for nested procedures!
   let bcplPair = firstPair;  // where the bcpl pairs start
   let bcplReturn = buf;  // the latest bcpl entry return address
   let bcplEnd = buf;  // the latest bcpl BR end + 1
   for pair = firstPair to lastPair by 2 do
      [
      let entry = buf + #20 + pair!1;
      if entry!0 eq sta312 & entry!1 eq jsrRv370 & entry!3 eq jsrRv367 then
         [
         if entry ugr bcplEnd then bcplEnd = entry-1 + entry!-1; //new bcpl BR
         if entry ugr bcplReturn then  // new bcpl procedure
            [
            bcplReturn = entry
            let nests = 1;
            until nests eq 0 do
               [
               bcplReturn = bcplReturn + 1;
               if bcplReturn!0 eq sta312 & bcplReturn!1 eq jsrRv370 &
                bcplReturn!3 eq jsrRv367 then nests = nests + 1;
               if bcplReturn!0 eq jsrRv366 then nests = nests - 1;
               ]
            ]
         ]
      test entry uls bcplEnd % entry uls bcplReturn
         ifso unless entry uls bcplEnd & entry uls bcplReturn then
            IFSError(ecIllFormedXMOverlay);
         ifnot
            [
            let staticAddress = pair!0; let relativePC = pair!1;
            bcplPair = bcplPair + 2;
            for movePair = pair to bcplPair by -2 do
               [ movePair!0 = movePair!-2; movePair!1 = movePair!-1; ]
            bcplPair!-2 = staticAddress; bcplPair!-1 = relativePC;
            ]
      ]

// LoadOverlayIntoXM (cont'd)

   // Look for non-Bcpl pairs that have been declared XM Entry Points (XEPs)
   // and move them into the Bcpl group.
   let xepTable = isb>>ISB.xepTable
   let pair = firstPair
   until pair uge bcplPair do
      [
      for i = 1 to xepTable!0 do
         if pair!0 eq xepTable!i then
            [
            bcplPair = bcplPair-2
            let t = pair!0; pair!0 = bcplPair!0; bcplPair!0 = t
            t = pair!1; pair!1 = bcplPair!1; bcplPair!1 = t
            ]
      pair = pair+2
      ]

   // Adjust pair count to include only the non-Bcpl pairs, since those
   // are the only ones that should participate in overlay fault fixups.
   firstPair!-1 = (bcplPair-firstPair) rshift 1

   // Now construct XJMP blocks for all the Bcpl pairs, except those
   // that have already been declared OEPs.
   for pair = bcplPair to lastPair by 2 do
      [
      let pStatic, pCode = pair!0, xBase + #20 + pair!1
      let xjmp = nil;  // xjmp is where to put the XJMP instruction
      test Usc(@pStatic-FirstOEP, EndOEP-FirstOEP) ls 0  // OEP?
         ifso
            [  // yes, turn OEP block into XJMP block
            xjmp = lv (@pStatic)>>OEP.JSRJMP
            ]
         ifnot
            [  // no, create an XJMP block
            xjmp = isb>>ISB.initStart; isb>>ISB.initStart = xjmp+2
            @pStatic = xjmp
            ]
      xjmp!0 = XJMP0 + bank;
      xjmp!1 = pCode
      ]

   // If this overlay is already present, copy the modified fixup vector
   // into the present overlay so that the Bcpl statics don't get clobbered
   // when the overlay is released.
   if od>>OD.core ne 0 then
      MoveBlock(od>>OD.core + ((firstPair-1)-buf), firstPair-1,
       (lastPair+2)-(firstPair-1))

   // Copy the overlay into XM
   DoubleBlt(xBase, buf, nPages lshift logOvPageSize, bank lshift 2)
   Free(sysZone, buf)
   ]
]

//----------------------------------------------------------------------------
and CountBanks() = valof
//----------------------------------------------------------------------------
// Returns zero if this is a non-XM Alto, or 1 through 4 depending on the
// number of (contiguous) memory banks present.  As a side-effect, corrects
// parity in all banks (>0) that are present.
[
if AltoVersion<<VERS.eng ne 3 resultis 0  // An XM Alto is an "Alto 3"
let nBanks = 4
@activeInterrupts = @activeInterrupts & 177776b  // Disable parity interrupt
for bank = 1 to 3 do
   [
   StoreXM(bank, 0, 125252b); let r1 = LoadXM(bank, 0)
   StoreXM(bank, 0, 52525b); let r2 = LoadXM(bank, 0)
   if r1 ne 125252b % r2 ne 52525b then
      [ nBanks = bank; break ]
   DoubleBlt(0, 0, 177000b, bank lshift 2)  // dest=bank, source=0
   ]
@wakeupsWaiting = @wakeupsWaiting & 177776b  // Flush pending parity interrupt
@activeInterrupts = @activeInterrupts % 1  // Reenable parity interrupt
resultis nBanks
]