~trn/reduce-algebra

2914b5514dc6e5abc9e038bad1f80d10828ed5e8 — Jeffrey H. Johnson 2 days ago ca0a978 + da8a966
Merge branch 'svn/trunk'
M csl/cslbase/fwin.cpp => csl/cslbase/fwin.cpp +3 -3
@@ 477,9 477,9 @@ void mac_deal_with_application_bundle(int argc, const char *argv[])
// These days I can not even be certain that calling std::exit() will cause
// and application to terminate (I think) but the use here should NEVER get
// called and so just what happens here is not that important!
            std::fflush(stdout);
            std::fflush(stderr);
            if (spool_file != nullptr) std::fflush(spool_file);
            // std::fflush(stdout);
            // std::fflush(stderr);
            // if (spool_file != nullptr) std::fflush(spool_file);
            std::exit(1);
        }
    }

M packages/support/revision.red => packages/support/revision.red +1 -1
@@ 31,6 31,6 @@

fluid '(revision!*);

revision!* := 6018;
revision!* := 6025;

end;

M psl/dist/comp/aarch64/aarch64-cmac.sl => psl/dist/comp/aarch64/aarch64-cmac.sl +44 -3
@@ 483,16 483,16 @@

(de quotep (x) (eqcar x 'quote))

(de quotedstringp (x) (and (quotep x) (stringp (cadr x))))

%% optimize (*Move nil (fluid something))
(DefCMacro *Move
       (Equal)
       ((regp regp)              (MOV ArgTwo ArgOne))
%       ((imm8-rotatedp regp)     (MOV Argtwo ArgOne))
       ((quotedstringp regp)     (*LoadString ArgTwo ArgOne))
       ((quotep regp)            (LDR ArgTwo ArgOne))
       ((InumP regp)             (*LoadConstant ArgTwo ArgOne))
       ((fixp regp)              (*LoadConstant ArgTwo ArgOne))
%       ((true-p regp)            (*LoadIDLoc t ArgTwo)
%                                (*MkItem ArgTwo (compiler-constant 'id-tag)))
       ((idlocp regp)            (*LoadIDLoc ArgTwo ArgOne))
       ((fluid-arg-p regp)       (*LoadIdNumber LDR ArgTwo ArgOne))
       ((indirectp regp)         (LDR ArgTwo ArgOne))


@@ 506,6 506,47 @@
       (                         (*Move ArgOne (reg t1))
                                 (*Move (reg t1) ArgTwo)))

%%% *LoadString loads a string object into a register. Normally, this would be handled
%%% like any quoted expression, by expanding into a set of memory words. However,
%%% this doesn't produce position independent code, which some systems do not like
%%% (the Mac M1 linker being among them). Fortunately, only string constants appear
%%% in the PSL kernel, hence we can get away by handling strings differently.
%%% Instead of producing
%%%
%%%  label1
%%%  (fullword nnn)          % the length of the string
%%%  (string "xyz")          % the actual string, 0-terminated
%%%   ...
%%%  (LDR (reg n) "label2")
%%%   ...
%%%  label2
%%%  (fullword (mkitem 4 "label1"))  % absolute address reference, non-pie
%%%
%%% we load the address of label1 into the destination register, add the string
%%% tag, dropping the fullword at label2:
%%%
%%%  label1
%%%  (fullword nnn)          % the length of the string
%%%  (string "xyz")          % the actual string, 0-terminated
%%%   ...
%%%  (ADR (reg n) "label1")
%%%  (MOV (reg t3) 4)
%%%  (BFI (reg n) (reg t3) 56 8)
%%%
%%% and have position independent code.
%%%
%%% For constants compiled or loaded at runtime, the address must be determined
%%% dynamically anyway, but it seems easier to apply this change to all strings.
%%% As for performance, the two extra instructions (MOV and BFI) per string constant,
%%% both without a memory access seems a price worth paying.

(de *LoadString (dest string)
    `( (ADR ,dest ,(SaveContents (cadr string)))
       (*MkItem ,dest (quote 4)))
)

(DefCMacro *LoadString)

%% ToDo!
(de *LoadConstant (dest cst)
    (cond ((sixteenbit-p cst)

A psl/dist/comp/macaarch64/Makefile => psl/dist/comp/macaarch64/Makefile +1 -0
@@ 0,0 1,1 @@
../aarch64/Makefile
\ No newline at end of file

A psl/dist/comp/macaarch64/aarch64-inst.dat => psl/dist/comp/macaarch64/aarch64-inst.dat +1 -0
@@ 0,0 1,1 @@
../aarch64/aarch64-inst.dat
\ No newline at end of file

A psl/dist/comp/macaarch64/carcdrnil.sl => psl/dist/comp/macaarch64/carcdrnil.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/carcdrnil.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/comp-decls.sl => psl/dist/comp/macaarch64/comp-decls.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/comp-decls.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/compat.sl => psl/dist/comp/macaarch64/compat.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/compat.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/compiler.sl => psl/dist/comp/macaarch64/compiler.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/compiler.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/geninstr.sl => psl/dist/comp/macaarch64/geninstr.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/geninstr.sl
\ No newline at end of file

M psl/dist/comp/macaarch64/macaarch64-asm.sl => psl/dist/comp/macaarch64/macaarch64-asm.sl +5 -1
@@ 38,6 38,10 @@
% Revisions:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% $Id$
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load if-system))



@@ 97,7 101,7 @@
(setq MainEntryPointName* '!m!a!i!n)     % chose a simple default
                                         % main procedure name

(setq NumericRegisterNames* '[nil "X0" "X1" "X2" "X3" "X4" "X5", "X6", "X7"])
(setq NumericRegisterNames* '[nil "X0" "X1" "X2" "X3" "X4" "X5" "X6" "X7"])

(setq LabelFormat* "%w:%n")             % Labels are in the first column
(setq CommentFormat* "// %p%n")          % Comments begin with //

A psl/dist/comp/macaarch64/macaarch64-cmac.sl => psl/dist/comp/macaarch64/macaarch64-cmac.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/aarch64-cmac.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/macaarch64-comp.sl => psl/dist/comp/macaarch64/macaarch64-comp.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/aarch64-comp.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/macaarch64-cross.sl => psl/dist/comp/macaarch64/macaarch64-cross.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/aarch64-cross.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/macaarch64-lap-to-asm.sl => psl/dist/comp/macaarch64/macaarch64-lap-to-asm.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/aarch64-lap-to-asm.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/macaarch64-lap.sl => psl/dist/comp/macaarch64/macaarch64-lap.sl +2936 -0
@@ 0,0 1,2936 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PXC:aarch64-LAP.SL
% Description:  Armv8/A64 PSL Assembler
% Author:       R. Schöpf
% Created:      21 November 2020
% Modified:     December 2020
% Mode:         Lisp
% Package:      
% Status:       Open Source: BSD License
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Revisions:
%
% 28-Apr-92 (herbert Melenk)
% no relocation for quoted small ID's
%
% 3-Apr-90 (Winfried Neun)
% added support for new car and cdr scheme in modr/m
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% $Id$
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load if-system))

% ------------------------------------------------------------
% Fluid declarations:
% ------------------------------------------------------------

(fluid '(LabelOffsets*                  % just the label entries from
					% BranchAndLabelAList!*
					% Has the form ( (Label.Offset) ... )
	BranchCodeList*                 % Used in Branch optimization
	BranchAndLabelAList*            % Used in Branch optimization
	CurrentOffset*                  % the global value of the current
					% byte displacement from the starting
					% point of the code
	CodeSize*                       % Current number of bytes generated
	CodeBase*                       % Starting address of the module
	Entries*                        % list of procedure entries of the
					% form
					% ((ProcedureName
					%   ProcedureType
					%   NumberOfArguments) .
					%   CurrentOffset!* )
	InstructionChanged*             % Boolean - indicates if any
					% instructions have changed due to
					% branch optimization
	InstructionSize*                % Contains the size constant Byte
					% Word or Long during length compute
					% and assembly of individual instr.
	ForwardInternalReferences*      % a-list of offsets of references to
					% internal functions, to be patched
					% by SystemFaslFixup
	LapReturnValue*                 % set by SaveEntry to the pointer
					% to be returned by LAP
	OperandRegisterNumber*          % see EffectiveAddress
	*WritingFaslFile                % FLAG: if true, then we are writing
					% the resulting code to a file,
					% otherwise we are depositing it into
					% memory directly
	InitOffset*                     % The offset from the module to the
					% Initialiization code which is to be
					% run when the module is loaded
	*PGWD                           % FLAG: if true, then mnemonics and
					% assembled instructions are printed
	*PWrds                          % FLAG: if true, then base address
					% and size of each compiled
					% procedure are printed as they are
					% deposited into memory
	*lapopt
	*trlapopt
	*big-endian*    		% True if big-endian version
	shift-ops*			% known armv6 shift operations
	*condition-codes*               % aarch64 condition codes
	lapcomment*                     % optional comment in lap output
%	*cond*
%	*set*
	*OpNameList*
	!*LDM-adressing-modes

))

(setq *lapopt t)

(fluid '(*immediatequote))
(setq *immediatequote nil)
(fluid '(*testlap))                     % diagnostic output from LAP  MK

(ds LabelP (X) (atom X))

(setq *PWrds t)                         % By default show where the code is
					% put in memory

(setq shift-ops* '(LSL LSR ASR ROR RRX))

%
% Conditions bits 31:28 in ARMv6 opcodes
%

(deflist '((EQ 2#0000) (NE 2#0001) (CS 2#0010) (HS 2#0010) (CC 2#0011) (LO 2#0011)
           (MI 2#0100) (PL 2#0101) (VS 2#0110) (VC 2#0111)
           (HI 2#1000) (LS 2#1001) (GE 2#1010) (LT 2#1011)
           (GT 2#1100) (LE 2#1101) (AL 2#1110))
  'condition-bits)

(deflist '(( EQ NE ) ( NE EQ )
	   ( CS CC ) ( CC CS )
	   ( MI PL ) ( PL MI )
	   ( VS VC ) ( VC VS )
	   ( HI LS ) ( LS HI )
	   ( GE LT ) ( LT GE )
	   ( GT LE ) ( LE GT )
	   )
  'inverted-condition)

(setq *condition-codes* '(EQ NE CS HS CC LO MI PL VS VC HI LS GE LT GT LE AL))

(de invert-cond (cond)
    (get cond 'inverted-condition))

(compiletime
 (if_system x86_64
   (progn
     (put 'put_a_halfword 'opencode '((movl (reg ebx) (displacement (reg rax) 0))))
     (put 'getword32 'opencode '((movl (indexed (reg 1) (displacement (reg 2) 0)) (reg EAX)))))
   (progn
     (put 'put_a_halfword 'opencode '((STR (reg w1) (displacement (reg x0) 0))))
     (put 'getword32 'opencode '((LDR (reg w0) (indexed (reg 1) (reg 2)) ))))
   ))


% ------------------------------------------------------------
% Constant declarations:
% ------------------------------------------------------------

(DefConst  
	 RELOC_ID_NUMBER 1 
	 RELOC_HALFWORD 2 
	 RELOC_WORD 1 
	 RELOC_INF 3)

(DefConst MaximumPCRelLoadOffset 4096)

% ------------------------------------------------------------
% Start of actual code
% ------------------------------------------------------------

(de Lap (U) 
(prog (LabelOffsets* LapReturnValue* Entries* temp) 
    (cond ((not *WritingFaslFile) (setq CurrentOffset* 0))) 
    (setq U (&fillframeholes u))
    
%%%    (setq u (lapopt1 u))                % optimize macros

    (setq U (Pass1Lap U))               % Pass1lap
					% expand all the LAP macros
					% Note that this is defined in
					% PC:PASS-1-LAP.SL
    (setq U (LapoptFrame u))            % optimize frame-register transports
    (setq U (LapoptPeep u))             % peephole optimizer for aarch64 code

    (when *WritingFaslFile       % round off to fullword address
	  (while (not (eq (wshift (wshift currentOffset* -3) 3) currentOffset*))
		 (DepositByte 0) ))
 
    (SETQ U (ReformBranches U))         % process conditional branches
    (setq U (OptimizeBranches U))       % optimize branches and
					% calculate offsets and total length
    
    (when (not *WritingFaslFile)       
	  (setq CodeBase* (GTBPS (Quotient (Plus2 CodeSize* 3) 4))))


% Print the machine specific assembly code
% if the object is an atom then it is a LABEL
% otherwise it is an instruction

    (cond (*PGWD (foreach X in U do 
	(cond ((LabelP X) (Prin2 X)) (t (PrintF "          %p%n" X)))))) 

    (foreach Instruction_or_Label in U do 
	(cond
	    ((LabelP Instruction_or_Label) (DepositLabel Instruction_or_Label))
	    ((equal (first Instruction_or_Label) '*entry) 
		      (SaveEntry Instruction_or_Label)) 
	    (t (DepositInstruction Instruction_or_Label) )))

    (DefineEntries)                     % define entries to whom?

% If you are depositing it into memory the tell the user how much space the
% code took and where it was loaded.
% ??? Why is this using the error channel ???

    (cond ((and (not *WritingFaslFile) *PWrds) 
	(ErrorPrintF "*** %p: base 16#%x, length 10#%d bytes" 
		(foreach X in Entries* collect (first (car X))) 
				CodeBase* CodeSize*))) 

% If writing into memory, flush the caches

    (cond ((not *WritingFaslFile)
	   (clear_cache CodeBase* (wplus2 CodeBase* CodeSize*))))

    (return (and LapReturnValue*	  % return nil if LapReturnValue* is not set
	     (MkCODE LapReturnValue*))))) % How does this point at the code?
					  % It is a fluid variable that got
					  % set up when the code was generated.


% CheckForInitCode will scan the Codelist for the first !*Entry
% testing for !*!*FASL!*!*Initcode!*!*.

(de CheckForInitCode (CodeList) 
     (foreach Instruction in CodeList do 
       (progn (cond ((PairP Instruction) 
	   (cond ((equal (car Instruction) '*entry) 
	     (cond ((equal (second Instruction) '**Fasl**InitCode**) 
		(return t))))))))))

% SaveEntry( '(!*entry ProcedureName ProcedureType NumberOfArguments) )
% Purpose: To associate with a procedure its location (so other routines can
%          access it

(de saveentry (x)
  (cond  
   % if X = ( _____ !*!*!*Code!*!*Pointer!*!*!* ... )
   ((equal (second x) '***code**pointer***) 
    (setq lapreturnvalue* 
      (if *writingfaslfile CurrentOffset* (wplus2 CodeBase* CurrentOffset*))))

   % If depositing into memory
   ((not *writingfaslfile) 
    (setq entries* (cons (cons (rest x) CurrentOffset*) entries*)) 
    (unless lapreturnvalue* (setq lapreturnvalue*
		 (wplus2 CodeBase* CurrentOffset*))))

   % if X = ( _____ !*!*Fasl!*!*InitCode!*!* ... )
   ((equal (second x) '**fasl**initcode**) 
    (setq initoffset* CurrentOffset*))

   % if X is an InternalFunction
   ((flagp (second x) 'internalfunction) 
    (put (second x) 'internalentryoffset CurrentOffset*))

   (t (progn
       (put (second x) 'internalentryoffset CurrentOffset*) % MK
       (findidnumber (second x))
       (dfprintfasl (list 'putentry (mkquote (second x)) 
			  (mkquote (third x)) CurrentOffset*))))))
     

% DefineEntries()
% Purpose: Defines each of the procedures named in the list Entries!*
%          by putting the code pointer into the function cells

(de DefineEntries nil 
    (foreach X in Entries* do 
	(PutD (first (car X)) (second (car X))
		 (MkCODE (wplus2 CodeBase* (cdr X))))))

(commentoutcode
(de DepositInstruction (X)
% This actually dispatches to the procedures to assemble the instrucitons
(prog (Y)
    (cond ((setq Y (get (first X) 'InstructionDepositFunction))
	   (Apply Y (list X)))
	  ((setq Y (get (first X) 'InstructionDepositMacro))
	   (apply3safe y (cdr x))) 
	  (t (StdError (BldMsg "Unknown ARMv6 instruction %p" X))))))
)

(de DepositLabel (x) nil)

(commentoutcode
(de string-begins-with (s opname)
    (if (lessp (size s) (size opname))
	nil
      (equal (subseq s 0 (add1 (size opname))) opname)))

(de lookup-mnemonic (s)
    %% find opcode in *OpNameList* by comparing the first characters of x
    (prog (x)
	  (setq s (string s))
	  (setq x *OpNameList*)
	  lbl
	  (if (string-begins-with s (car x))
	      (return (car x)))
	  (setq x (cdr x))
	  (go lbl)))


(de get-instruction-deposit-function (mnemonic)
%%
%% first tries with mnemonic,
%%  then with trailing S stripped, then with condition codes stripped
%%
    (setq mnemonic (string mnemonic))
    (prog (generic-opname rest set!? conds fn variants z len size size1 substr )
	  (setq generic-opname (lookup-mnemonic mnemonic))
	  (setq rest (subseq mnemonic (add1 (size generic-opname)) (add1 (size mnemonic))))
	  (setq generic-opname (intern generic-opname))
	  (setq fn (get generic-opname 'InstructionDepositMacro))
	  (setq variants (get generic-opname 'OpCodeVariants))
	  (setq len (add1 (size rest)))
	  (foreach x in
		   (list (list '*set* '(s) 0)
			 (list '*ldm-addr* !*LDM-adressing-modes 'IA)
			 (list '*cond* !*condition-codes!* 'AL))
		   do
		   (if (memq (car x) variants)
		       (progn
			 (setq size1 (add1 (size (car (cddr x)))))
			 (setq substr (subseq rest (difference size size1) size))
			 (if (memq (intern substr) (cadr x)) % found
			     (push (cons (car x) (intern substr)) z)
			   (push (cons (car x) (caddr x)) z))
			 ))
		   )

	  (if fn (return (list fn (cons generic-opname z))))

	  )
    )
)

(fluid '(*testlap))
(de DepositInstruction (X) 
% This actually dispatches to the procedures to assemble the instructions
% version with address calculation test
(prog (Y l offs) 
      (when *testlap (prin2 CurrentOffset*) (tab 10) (print x))
      (if (flagp (first X) 'ForceAlignment)
	  (ForceAlignment))
      (when *writingfaslfile (setq offs CurrentOffset*))
      (cond ((setq Y (get (first X) 'InstructionDepositFunction)) 
	     (Apply Y (list X)))
	    ((setq Y (get (first X) 'InstructionDepositMacro))
	     (apply4safe y (cdr x)))
	    (t (StdError (BldMsg "Unknown Aarch64 instruction %p" X))))
      (when (and offs (not (equal CurrentOffset* (plus offs (InstructionLength x)))))
	(StdError (BldMsg "length error with instruction %p: %p"
			  x (difference (difference CurrentOffset* offs)
					(InstructionLength x)))))
      ))

(de DepositLabel (x) 
    (when *testlap (prin2 CurrentOffset*) (tab 10) (print x))
    (when (and *writingfaslfile 
	       (not (equal CurrentOffset* (LabelOffset x)))) 
	  (StdError (BldMsg "wrong address for label %p: difference = %p" 
		       x    (difference CurrentOffset* (LabelOffset x)))))) 
	   

(CompileTime (progn 

(dm DefOpcode (U) 
%
% (DefOpcode name (parameters) pattern)
%
(prog (OpName vars pattern fname) 
    (setq U (rest U)) 
    (setq OpName (pop U))   
    (setq fname (intern (bldmsg "%w.INSTR" OpName)))
    (setq OpName (MkQuote OpName)) 
    (setq vars (pop u)) 
    (setq pattern
      (append u
	`((t (laperr ',OpName  (list .,vars))))))
    (setq pattern (cons 'cond pattern))
    % (setq u `(lambda ,vars ,pattern)) 
    % (return `(put ,OpName 'InstructionDepositMacro ',u))
    (return
      `(progn
	 (de ,fname ,vars ,pattern)
	 (put ,OpName 'InstructionDepositMacro ',fname)))
 ))

(dm DefOpLength (U)
%
% (DefOpLength name (parameters) pattern)
%
(prog (OpName vars pattern fname)
    (setq U (rest U))
    (setq OpName (pop U))   % (quote name)
    (setq fname (intern (bldmsg "%w.LTH" OpName)))
    (setq OpName (MkQuote OpName))   % (quote name)
    (setq vars (pop u)) 
    (setq pattern
      (append u 
	`((t (laperr ',OpName  (list .,vars))))))  
    (setq pattern (cons 'cond pattern)) 
    % (setq u `(lambda ,vars ,pattern))
    % (return `(put ,OpName 'InstructionLengthFunction ',u))
    (return 
      `(progn
	 (de ,fname ,vars ,pattern) 
	 (put ,OpName 'InstructionLengthFunction ',fname))) 
)) 
 
 
 
))


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  additional test functions

(fluid '(sregs))
(setq sregs '(ES CS SS DS FS GS ))

(de RegP (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '( 1  2  3  4  5  6  7  8
                     X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15
		     X16 X17 X18 X19 X20 X21 X22 X23 X24 X25 X26 X27 X28 X29 X30
                     W0 W1 W2 W3 W4 W5 W6 W7 W8 W9 W10 W11 W12 W13 W14 W15
		     W16 W17 W18 W19 W20 W21 W22 W23 W24 W25 W26 W27 W28 W29 W30
		     fp lr Xzr Wzr
		     t1 t2 t3 t4 t5
             nil heaplast heaptrapbound symfnc symval
	     bndstkptr bndstklowerbound bndstkupperbound
	     ))))

(de Reg32P (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '(    W0 W1 W2 W3 W4 W5 W6 W7 W8 W9 W10 W11 W12 W13 W14 W15
		     W16 W17 W18 W19 W20 W21 W22 W23 W24 W25 W26 W27 W28 W29 W30
		     Wzr
	     ))))

(de Regfp8P (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '(    B0 B1 B2 B3 B4 B5 B6 B7 B8 B9 B10 B11 B12 B13 B14 B15
		     B16 B17 B18 B19 B20 B21 B22 B23 B24 B25 B26 B27 B28 B29 B30
		     B31
	     ))))

(de Regfp16P (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '(    H0 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 H14 H15
		     H16 H17 H18 H19 H20 H21 H22 H23 H24 H25 H26 H27 H28 H29 H30
		     H31
	     ))))

(de Regfp32P (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '(    S0 S1 S2 S3 S4 S5 S6 S7 S8 S9 S10 S11 S12 S13 S14 S15
		     S16 S17 S18 S19 S20 S21 S22 S23 S24 S25 S26 S27 S28 S29 S30
		     S31
	     ))))

(de Regfp64P (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '(    D0 D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14 D15
		     D16 D17 D18 D19 D20 D21 D22 D23 D24 D25 D26 D27 D28 D29 D30
		     D31
	     ))))

(de Regfp128P (RegName) 
    (AND (eqcar Regname 'reg)
	 (MemQ (cadr RegName) 
	       '(    Q0 Q1 Q2 Q3 Q4 Q5 Q6 Q7 Q8 Q9 Q10 Q11 Q12 Q13 Q14 Q15
		     Q16 Q17 Q18 Q19 Q20 Q21 Q22 Q23 Q24 Q25 Q26 Q27 Q28 Q29 Q30
		     Q31
	     ))))

(de reg-zero-p (RegName)
    (AND (eqcar Regname 'reg) (eq (cadr RegName) 'XZr)))

(de reg32-zero-p (RegName)
    (AND (eqcar Regname 'reg) (eq (cadr RegName) 'Wzr)))

(de reg-nonzero-p (RegName)
    (and (regp RegName) (not (reg-zero-p RegName))))

(de reg32-nonzero-p (RegName)
    (and (reg32p RegName) (not (reg32-zero-p RegName))))

(de reg-zero-p (RegName)
    (AND (eqcar Regname 'reg) (eq (cadr RegName) 'XZr)))

(de reg32-zero-p (RegName)
    (AND (eqcar Regname 'reg) (eq (cadr RegName) 'Wzr)))

(de reg-sp-p (RegName)
    (AND (eqcar Regname 'reg) (memq (cadr RegName) '(sp st))))

(de reg32-sp-p (RegName)
    (AND (eqcar Regname 'reg) (eq (cadr RegName) 'Wsp)))

(de reg-or-sp-p (RegName)
    (or (and (regp RegName) (not (reg-zero-p RegName)))
	(reg-sp-p RegName)))

(de reg32-or-sp-p (RegName)
    (or (and (reg32p RegName) (not (reg32-zero-p RegName)))
	(reg32-sp-p RegName)))

(de reg-indirect-p (x)
    (and (eqcar x 'indirect)
    	 (regp (cadr x))))

(de reg-or-sp-simm9-post-p (x)
    (and (eqcar x 'postindexed)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (simm9-p (caddr x))))

(de reg-or-sp-simm9-pre-p (x)
    (and (eqcar x 'preindexed)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (simm9-p (caddr x))))

(de reg-or-sp-simm9-p (x)
    (and (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (simm9-p (caddr x))))

(de simm9-p (displ)
    (and (fixp displ) (greaterp displ -257) (lessp displ 256)))

(de reg-or-sp-imm9-post-p (x)
    (and (eqcar x 'postindexed)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (imm9-p (caddr x))))

(de reg-or-sp-imm9-pre-p (x)
    (and (eqcar x 'preindexed)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (imm9-p (caddr x))))

(de reg-or-sp-imm9-p (x)
    (or (and (eqcar x 'indirect) (pairp (cdr x)) (reg-or-sp-p (cadr x)))
	(and (eqcar x 'displacement)
	     (pairp (cdr x)) (reg-or-sp-p (cadr x))
	     (pairp (cddr x)) (imm9-p (caddr x)))))

(de imm9-p (displ)
    (and (fixp displ) (greaterp displ -257) (lessp displ 253) (eq (land displ 2#11) 0)))

(de reg-or-sp-imm10-post-p (x)
    (and (eqcar x 'postindexed)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (imm10-p (caddr x))))

(de reg-or-sp-imm10-pre-p (x)
    (and (eqcar x 'preindexed)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (imm10-p (caddr x))))

(de reg-or-sp-imm10-p (x)
    (or (and (eqcar x 'indirect) (pairp (cdr x)) (reg-or-sp-p (cadr x)))
	(and (eqcar x 'displacement)
	     (pairp (cdr x)) (reg-or-sp-p (cadr x))
	     (pairp (cddr x)) (imm10-p (caddr x)))))

(de imm10-p (displ)
    (and (fixp displ) (greaterp displ -513) (lessp displ 505) (eq (land displ 2#111) 0)))

(de reg-or-sp-pimm16-p (x)
    (and (eqcar x 'displacement)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (fixp (caddr x)) (eq 0 (land (caddr x) 15))
	 (pimm12-p (lsh (caddr x) -4))
	 ))

(de reg-or-sp-pimm15-p (x)
    (and (eqcar x 'displacement)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (fixp (caddr x)) (eq 0 (land (caddr x) 7))
	 (pimm12-p (lsh (caddr x) -3))
	 ))

(de reg-or-sp-pimm14-p (x)
    (and (eqcar x 'displacement)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (fixp (caddr x)) (eq 0 (land (caddr x) 3))
	 (pimm12-p (lsh (caddr x) -2))
	 ))

(de reg-or-sp-pimm13-p (x)
    (and (eqcar x 'displacement)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (fixp (caddr x)) (eq 0 (land (caddr x) 1))
	 (pimm12-p (lsh (caddr x) -1))
	 ))

(de reg-or-sp-pimm12-p (x)
    (and (eqcar x 'displacement)
	 (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x)) (fixp (caddr x))
	 (pimm12-p (caddr x))
	 ))

(de pimm12-p (displ)
    (and (greaterp displ -1) (lessp displ 2#1000000000000)))

(de EvenRegP (RegName)
    (and (Regp RegName) (evenp (reg2int regname))))
	 
(de reglistp (x)
    (and (pairp x) (regp (car x)) (reglistp1 (cdr x))))

(de reglistp1 (x)
    (or (null x)
	(and (pairp x) (regp (car x))
	     (reglistp1 (cdr x)))))


(de memoryp(x) 
  % supports reference to explicit addresses
   (if (atom x) nil
       (progn
	 (setq x (car x))
	 (or
	   (eq x 'label) 
	   (eq x '$FLUID)
	   (eq x '$GLOBAL)
   )))) 
 
(de effap(x)
  % supports most general memory and register references
   (or (stringp x) (idp x) (regp x)
      (and (pairp x)
       (memq (car x)
	     '(indirect displacement indexed $fluid $global 
	       fluid global extrareg) ))))

(de stdimmediatep(x)
  % full size immediate
  (or (numberp x)(eqcar x 'immediate)(eqcar x 'idloc)))

(de shortlabelp (x)(or (labelp x) (eqcar x 'IMMEDIATE)))

(de adrp (x) (or (atom x)
		 (memq (car x)'(label entry internalentry foreignentry))
		 (and (eqcar x 'IMMEDIATE) (adrp (cadr x)))))
  
(de indirectadrp (x) (and (eqcar x 'INDIRECT) 
			  (or (adrp (cadr x)) (effap (cadr x))(regp (cadr x)))))

(de smallimmediatep (x)
     (when (eqcar x 'IMMEDIATE) (setq x (unimmediate x)))
     (imm8-rotatedp x)) 

(de imm8-rotatedp (x)
    (and (fixp x)
	 (setq x (wand 16#ffffffff x))
	 (decode-32bit-imm8-rotated x)))

(de imm12-shiftedp (x)
    (or (and (fixp x) (eq x (land x 16#fff)))
	(and (fixp x) (eq x (land x 16#fff000)))
	(and (pairp x) (fixp (car x)) (eq (car x) (land (car x) 16#fff))
	     (eqcar (cdr x) 'LSL)
	     (pairp (cddr x)) (memq (caddr x) '(0 12)))))

(de imm12-neg-shiftedp (x)
    (and (Inump x) (imm12-shiftedp (wminus x))))

(de imm16-shiftedp (x)
    (or (and (fixp x) (eq x (land x 16#ffff)))
	(and (pairp x) (fixp (car x)) (eq (car x) (land (car x) 16#ffff))
	     (eqcar (cdr x) 'LSL)
	     (pairp (cddr x)) (memq (caddr x) '(0 16 32 48)))))

(de imm-lg-repeated (x)
  (let ((size 64) (mask))
    (while (greaterp size 2)
      (setq size (lsh size -1))
      (setq mask (lsh -1 (minus size)))
      (if (not (eq (land mask x) (land mask (lsh x (minus size)))))
	  (return (lsh size 1)))
      (setq size (lsh size -1)))
    ))

(de imm-logical-p (x)
    (prog (size mask imm tmp zz ones immr Nimms N)
    (if (null (fixp x)) (return nil))
    (if (null (setq size (imm-lg-repeated x)))
        (return nil))
    (setq mask (lsh -1 (difference size 64)))
    (setq imm (land x mask))
    (setq tmp (lor (sub1 imm) imm))
    (if (and (not (eq imm 0)) (eq 0 (land (add1 tmp) tmp)))
	(progn
	  %% count trailing zeros
	  (setq zz 0 tmp imm)
	  (while (and (lessp zz 64) (eq 0 (land tmp 1)))
	    (setq tmp (lsh tmp -1) zz (add1 zz))
	    )
	  (if (greaterp zz 63) (return nil))
	  %% now count ones
	  (setq ones 0)
	  (while (eq 1 (land tmp 1))
	    (setq tmp (lsh tmp -1) ones (add1 ones))))
      (progn
	(setq imm (lor imm (lnot mask)))
	(if (eq 0 (lnot imm)) (return nil))
	(setq tmp (lor (sub1 (lnot imm)) (lnot imm)))
	(if (not (eq 0 (land (add1 tmp) tmp))) (return nil))
	(setq zz 64 tmp imm)
	(while (lessp tmp 0)
	  (setq tmp (lsh tmp -1)) (zz (sub1 zz)))
	(setq ones 0 tmp imm)
	(while (eq 1 (land tmp 1))
	  (setq tmp (lsh tmp -1) ones (add1 ones)))
	(setq ones (difference (plus2 (difference 64 zz) ones)
			       (diffference 64 size)))
	))
    (if (not (greaterp size zz)) (return nil))
    (setq immr (land (difference size zz) (sub1 size)))
    (setq Nimms (lsh (lnot (sub1 size)) 1))
    (setq Nimms (lor Nimms (sub1 ones)))
    (setq N (lxor (land (lsh Nimms -6) 1) 1))
    (return (lor (lsh N 12) (lor (lsh immr 6) (land Nimms 16#3f))))
    )
  )

(de five-bit-p (x)
    (and (fixp x) (eq (wand 16#1f x) x)))

(de six-bit-p (x)
    (and (fixp x) (eq (wand 16#3f x) x)))

(de sixteenbit-p (x)
    (and (fixp x) (eq (wand 16#ffff x) x)))

(de nineteenbit-p (x)
    (and (fixp x) (eq (wand 16#7ffff x) x)))

%(de thirtytwobit-p (x)
%    (and (fixp x) (equal (wand 16#ffffffff x) x)))

% possibly shifted register (data movement), one of:
% (reg x)
% (regshifted x LSL/LSR.. amount)    amount is a number or a register
% (regshift-by-reg x LSL/LSR (reg y))

(de reg-shifter-p (x)
    (or (stringp x)
	(and (pairp x) (regp x))
	(and (eqcar x 'regshifted) (or (regp (cadr x)) (regp (list 'reg (cadr x))))
	     (memq (caddr x) '(LSL LSR ASR))
	     (or (fixp (cadddr x)) (regp (cadddr x))
		 (and (null (cadddr x)) (eq (caddr x) 'RRX))))
	)
    )

(de reg32-shifter-p (x)
    (or (stringp x)
	(and (pairp x) (reg32p x))
	(and (eqcar x 'regshifted) (or (reg32p (cadr x)) (reg32p (list 'reg (cadr x))))
	     (memq (caddr x) '(LSL LSR ASR))
	     (or (fixp (cadddr x)) (reg32p (cadddr x))
		 (and (null (cadddr x)) (eq (caddr x) 'RRX))))
	)
    )

(de reg-or-sp-shifter-p (x)
    (and (eqcar x 'indexed)
         (pairp (cdr x)) (reg-or-sp-p (cadr x))
	 (pairp (cddr x))
	 (let ((indx (caddr x)))
	   (or (regp indx)
	       (and (eqcar indx 'regshifted) (or (regp (cadr indx)) (regp (list 'reg (cadr indx)))) (eq 'LSL (caddr indx)))
	       (and (eqcar indx 'regextended) (or (reg32p (cadr indx)) (reg32p (list 'reg (cadr indx)))) (memq (caddr indx) '(SXTW UXTW)))))))

% possibly extended register (data movement), one of:
% (reg x)
% (regshifted x LSL/LSR.. amount)    amount is a number or a register
% (regshift-by-reg x LSL/LSR (reg y))

(de reg-extended-p (x)
    (or (stringp x)
%	(and (pairp x) (regp x))
	(and (eqcar x 'extend) (or (regp (cadr x)) (regp (list 'reg (cadr x))))
	     (memq (caddr x) '(UXTB UXTH LSL UXTW UXTX SXTB SXTH SXTW SXTX))
	     (fixp (cadddr x)))

	)
    )

(de reg32-extended-p (x)
    (or (stringp x)
	(and (pairp x) (reg32p x))
	(and (eqcar x 'extend) (or (reg32p (cadr x)) (reg32p (list 'reg (cadr x))))
	     (memq (caddr x) '(UXTB UXTH LSL UXTW UXTX SXTB SXTH SXTW SXTX))
	     (fixp (cadddr x)))

	)
    )

(de reg-offset8-p (x)
    (cond ((stringp x) t)
	  ((atom x) nil)
	  ((eq (car x) 'indirect) (regp (cadr x)))
	  ((and (memq (car x) '(displacement indirect indexed)) (regp (cadr x)))
	   (eight-bit-p (caddr x)))
	  (t nil)))

(de reg-offset12-p (x)
    (cond ((labelp x) t)
	  ((atom x) nil)
	  ((eq (car x) 'indirect) (regp (cadr x)))
	  ((and (memq (car x) '(displacement indirect indexed)) (regp (cadr x)))
	   (twelve-bit-p (caddr x)))

%	  (or
%	    (twelve-bit-p (caddr x))
%	    (reg-shifter-p (cadr x))
%	    (and (pairp (cadr x)) (memq (caadr x) '(plus minus)) (reg-shifter-p (cadr (cadr x))))))
	  (t nil))
    )
	      
(de twelve-bit-p (x)
    (and (fixp x) (lessp x 4096) (greaterp x -4096)))

(de pos-twelve-bit-p (x)
    (and (fixp x) (lessp x 4096) (greaterp x -1)))

(de eight-bit-p (x)
    (and (fixp x) (lessp x 256) (greaterp x -256)))

(de pm-reg-shifter-p (x)
    (and (eqcar x 'displacement indexed)
	 (regp (cadr x))
	 (and (pairp (caddr x)) (memq (car (caddr x)) '(reg regshifted plus minus))))
    )

(de streg-p (x)
    (or (eq x 'cpsr) (eq x 'spsr)))

(de writeback-p (x)
    t)

(de offset19-p (x)
    (or (labelp x)
	(eqcar x 'internalentry)
	(and (or (eqcar x 'immediate) (setq x (cadr x)))
	     (fixp x)
	     (lessp x (add1 16#FFFFC))
	     (greaterp x (sub1 -1048572))
	 )
	)
    )

(de offset21-p (x)
    (or (labelp x)
	(eqcar x 'internalentry)
	(and (or (eqcar x 'immediate) (setq x (cadr x)))
	     (fixp x)
	     (setq x (lsh x -2))
	     (lessp x (add1 16#FFFFC))
	     (greaterp x (sub1 -1048572))
	 )
	)
    )

(de offset26-p (x)
    (or (labelp x)
	(eqcar x 'internalentry)
	(eqcar x 'foreignentry)
	(and (or (eqcar x 'immediate) (setq x (cadr x)))
	     (fixp x)
	     (lessp x (add1 16#7FFFFFC))
	     (greaterp x (sub1 -134217728))
	 )
	)
    )


(de cond-p (cc) (memq cc *condition-codes*))
    
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
%  Instruction deposit functions
 

(de laperr(inst par)
   (StdError (BldMsg "Illegal format: (%p %p)" inst par)))


(de depositextension(op2)
   % generate a relocated fullword extension
    (prog (OfFn)
      (when (atom op2) (return (DepositWordExpression op2)))
    (when (setq OfFn (get (car op2) 'OperandDepositFunction))
	  (return (apply OfFn (list op2))))
    (DepositWordExpression op2)))
    

% Procedures to compute specific OperandRegisterNumber!*
% Each of the cases returns the Addrssing MODE
% and sets OperandRegisterNumber!* as a side effect

(fluid '(numericRegisterNames))

(setq numericRegisterNames [nil X0 X1 X2 X3 X4 X5 X6 X7])

(de reg2int (u)
   % calculate binary number for register
  (prog (r) (setq r u)
      % strip off tag 'reg
   (cond ((eqcar r 'reg)(setq r (cadr r))))
      %convert a LISP-register into a Aarch64 register
   (if (numberp r) (setq r (getv numericRegisterNames r)))
   (setq r (get r 'registercode))
   (if r (return r)
	 (stderror (bldmsg "unknown register %w" u)))))

(loadtime
(deflist '((X0   0) (X1   1) (X2   2) (X3   3) 
	   (X4   4) (X5   5) (X6   6) (X7   7)
	   (X8   8) (X9   9) (X10 10) (X11 11)
	   (X12 12) (X13 13) (X14 14) (X15 15)
	   (X16 16) (X17 17) (X18 18) (X19 19)
	   (X20 20) (X21 21) (X22 22) (X23 23)
	   (X24 24) (X25 25) (X26 26) (X27 27)
	   (X28 28) (X29 29) (X30 30) (Xzr 31)
	   (W0   0) (W1   1) (W2   2) (W3   3) 
	   (W4   4) (W5   5) (W6   6) (W7   7)
	   (W8   8) (W9   9) (W10 10) (W11 11)
	   (W12 12) (W13 13) (W14 14) (W15 15)
	   (W16 16) (W17 17) (W18 18) (W19 19)
	   (W20 20) (W21 21) (W22 22) (W23 23)
	   (W24 24) (W25 25) (W26 26) (W27 27)
	   (W28 28) (W29 29) (W30 30) (Wzr 31)
	   (B0   0) (B1   1) (B2   2) (B3   3) 
	   (B4   4) (B5   5) (B6   6) (B7   7)
	   (B8   8) (B9   9) (B10 10) (B11 11)
	   (B12 12) (B13 13) (B14 14) (B15 15)
	   (B16 16) (B17 17) (B18 18) (B19 19)
	   (B20 20) (B21 21) (B22 22) (B23 23)
	   (B24 24) (B25 25) (B26 26) (B27 27)
	   (B28 28) (B29 29) (B30 30) (B31 31)
	   (H0   0) (H1   1) (H2   2) (H3   3) 
	   (H4   4) (H5   5) (H6   6) (H7   7)
	   (H8   8) (H9   9) (H10 10) (H11 11)
	   (H12 12) (H13 13) (H14 14) (H15 15)
	   (H16 16) (H17 17) (H18 18) (H19 19)
	   (H20 20) (H21 21) (H22 22) (H23 23)
	   (H24 24) (H25 25) (H26 26) (H27 27)
	   (H28 28) (H29 29) (H30 30) (H31 31)
	   (S0   0) (S1   1) (S2   2) (S3   3) 
	   (S4   4) (S5   5) (S6   6) (S7   7)
	   (S8   8) (S9   9) (S10 10) (S11 11)
	   (S12 12) (S13 13) (S14 14) (S15 15)
	   (S16 16) (S17 17) (S18 18) (S19 19)
	   (S20 20) (S21 21) (S22 22) (S23 23)
	   (S24 24) (S25 25) (S26 26) (S27 27)
	   (S28 28) (S29 29) (S30 30) (S31 31)
	   (D0   0) (D1   1) (D2   2) (D3   3) 
	   (D4   4) (D5   5) (D6   6) (D7   7)
	   (D8   8) (D9   9) (D10 10) (D11 11)
	   (D12 12) (D13 13) (D14 14) (D15 15)
	   (D16 16) (D17 17) (D18 18) (D19 19)
	   (D20 20) (D21 21) (D22 22) (D23 23)
	   (D24 24) (D25 25) (D26 26) (D27 27)
	   (D28 28) (D29 29) (D30 30) (D31 31)
	   (Q0   0) (Q1   1) (Q2   2) (Q3   3) 
	   (Q4   4) (Q5   5) (Q6   6) (Q7   7)
	   (Q8   8) (Q9   9) (Q10 10) (Q11 11)
	   (Q12 12) (Q13 13) (Q14 14) (Q15 15)
	   (Q16 16) (Q17 17) (Q18 18) (Q19 19)
	   (Q20 20) (Q21 21) (Q22 22) (Q23 23)
	   (Q24 24) (Q25 25) (Q26 26) (Q27 27)
	   (Q28 28) (Q29 29) (Q30 30) (Q31 31)
	   (T1   9) (T2  10) (T3  11) (T4  12) (T5 13)
	   (fp  29)			% frame pointer for C subroutine calls
	   (sp  31) (st  31)		% LISP stack register
	   (lr  30)			% link register
	   (heaplast 21)
	   (heaptrapbound 22)
	   (symfnc 23)
	   (symval 24)
	   (bndstkptr 25)
	   (bndstklowerbound 26)
	   (bndstkupperbound 27)
	   (nil 28)
	 ) 'registercode)
)
(de bytep(n)
    (when (and (numberp n) (lessp n 128) (greaterp n -128))
	  (wand n 255)))
 
(de halfwordp(n)
    (when (and (numberp n) (lessp n 32768) (greaterp n -32768))
	  (wand n 65535)))

(de unimmediate(u)
    (if (eqcar u 'immediate) (cadr u) u))

%------------------------------------------------------------------------
(de OP-branch-imm (code offset)
    (setq offset (MakeExpressionRelative offset 0))
    (if (not (weq (land offset 2#11) 0))
	(stderror (bldmsg "Invalid immediate branch offset %w" offset))
      (progn
	(setq offset (ashift offset -2))
	(DepositInstructionBytes
	 (lor (lsh (car code) 2) (land (lsh offset -24) 3))
	 (land 16#ff (lshift offset -16))
	 (land 16#ff (lshift offset -8))
	 (land 16#ff offset))
	))
    )

(de lth-branch-imm (code offset) 4)

(de OP-branch-imm19 (code offset)
    (setq offset (MakeExpressionRelative offset 0))
    (if (not (weq (land offset 2#11) 0))
	(stderror (bldmsg "Invalid immediate branch offset %w" offset))
      (progn
	(setq offset (ashift offset -2))
	(DepositInstructionBytes
	 (car code)
	 (land 16#ff (lshift offset -11))
	 (land 16#ff (lshift offset -3))
	 (lor (land 16#ff (lsh offset 5)) (cadr code)))
	))
    )

(de lth-branch-imm19 (code offset) 4)

(de OP-cbz (code regt offset)
    (setq offset (MakeExpressionRelative offset 0))
    (if (not (weq (land offset 2#11) 0))
	(stderror (bldmsg "Invalid immediate branch offset %w" offset))
      (progn
	(setq offset (ashift offset -2))
	(DepositInstructionBytes
	 (car code)
	 (land 16#ff (lshift offset -11))
	 (land 16#ff (lshift offset -3))
	 (lor (land 16#ff (lsh offset 5)) (reg2int regt)))
	))
    )
    

(de OP-branch-reg (code regm)
    (prog (opcode)
	  (setq opcode (car code)) 
	  (DepositInstructionBytes
	   (lsh opcode -3)
	   (lor (lsh (land opcode 2#111) 5) 2#11111)
	   (lsh (reg2int regm) -3)
	   (lsh (land (reg2int regm) 2#111) 5)
	   )
	)
    )

(de lth-branch-reg (code reg) 4)

(de OP-ret (code) (OP-branch-reg code 'X30))

(de OP-adr (code regd offset)
    (setq offset (MakeExpressionRelative offset 0))
    (prog (byte1)
	(setq byte1 (lor (car code) (lsh (land offset 3) 5)))
	(setq offset (ash offset -2))
	(DepositInstructionBytes
	 byte1
	 (land 16#ff (lshift offset -11))
	 (land 16#ff (lshift offset -3))
	 (lor (lsh (land 16#7 offset) 5) (reg2int regd))
	 ))
    )

(de lth-adr (code regd offset) 4)

(de OP-reg-Xbfm (code regd regn lsb width)
    (prog (opcode)
	  (setq opcode (car code)) 
	  (DepositInstructionBytes
	   (lsh opcode -2)
	   (lor (lsh (land opcode 2#11) 6) lsb)
	   (lor (lsh width 2) (lsh (reg2int regn) -3))
	   (lor (lsh (land (reg2int regn) 2#111) 5) (reg2int regd))
	   )
	)
    )

(de lth-reg-Xbfm (code regd regn lsb width) 4)


(de OP-reg-Xbfx (code regd regn lsb width)
    (OP-reg-Xbfm code regd regn lsb (sub1 (plus2 lsb width)))
    )

(de lth-reg-Xbfx (code regd regn lsb width) 4)

(de OP-reg-Xbfiz (code regd regn lsb width)
    (OP-reg-Xbfm code regd regn (land (minus lsb) (if (reg32p regd) 2#11111 2#111111)) (sub1 width))
    )

(de lth-reg-Xbfiz (code regd regn lsb width) 4)

(de OP-reg-XxtX (code regd regn)
    (OP-reg-Xbfm code regd regn 0 (cadr code))
    )

(de lth-reg-XxtX (code regd regn lsb width) 4)

(de OP-reg-Xsl (code regd regn shift)
    (let ((base (if (reg32p regd) 2#11111 2#111111)))
        (OP-reg-Xbfm code regd regn (land (minus shift) base) (difference base shift))
    ))

(de lth-reg-Xsl (code regd regn lsb width) 4)

(de OP-reg-Xsr (code regd regn shift)
    (let ((base (if (reg32p regd) 2#11111 2#111111)))
        (OP-reg-Xbfm code regd regn shift base)
    ))

(de lth-reg-Xsr (code regd regn lsb width) 4)

(de OP-reg-Xsrv (code regd regn regm)
    (DepositInstructionBytes
     (lsh (car code) -3)
     (lor (lsh (land (car code) 2#111) 5)
	  (reg2int regm))
     (lor (lsh (cadr code) 2)
	  (lsh (reg2int regn) -3))
     (lor (lsh (land (reg2int regn) 2#111) 5)
	  (reg2int regd))
    ))

(de lth-reg-Xsrv (code regd regn regm) 4)

(de OP-bfm (code regd regn immr imms)
    (prog (opcode)
	  (setq opcode (car code)) 
	  (DepositInstructionBytes
	   (lsh opcode -2)
	   (lor (lsh (land opcode 2#11) 6) immr)
	   (lor (lsh imms 2) (lsh (reg2int regn) -3))
	   (lor (lsh (land (reg2int regn) 2#111) 5) (reg2int regd))
	   )
	)
   
    )

(de lth-bfm (code regd regn immr imms) 4)

(de OP-bfc (code regd lsb width)
    (OP-bfm code regd (list 'reg (if (reg32p regd) 'Xzr 'Wzr)) (land (minus lsb) (if (reg32p regd) 2#11111 2#111111)) (sub1 width))
    )

(de lth-bfc (code regd lsb width) 4)

(de OP-bfi (code regd regn lsb width)
    (OP-bfm code regd regn (land (minus lsb) (if (reg32p regd) 2#11111 2#111111)) (sub1 width))
    )

(de lth-bfi (code regd regn lsb width) 4)

(de OP-bfxil (code regd regn lsb width)
    (OP-bfm code regd regn lsb (sub1 (plus2 lsb width)))
    )

(de lth-bfxil (code regd regn lsb width) 4)

(de OP-csinc (code regd regn regm cond)
    (prog (opcode)
	  (setq opcode (car code)) 
	  (DepositInstructionBytes
	   (lsh opcode -3)
	   (lor (lsh (land opcode 2#111) 5) (reg2int regm))
	   (lor (lor (lsh (get cond 'condition-bits) 4) (lsh (caddr code) 2)) (lsh (reg2int regn) -3))
	   (lor (lsh (land (reg2int regn) 2#111) 5) (reg2int regd))
	   )
	)
   
    )

(de lth-csinc (code regd regn regm cond) 4)

(de OP-cset (code regd cond)
    (OP-csinc code regd (list 'reg (cadr code)) (list 'reg (nth code 4)) (invert-cond cond)))

(de saniere-Sprungziel (l)
    (cond ((atom l) l)
	  ((eqcar l 'IMMEDIATE) (saniere-Sprungziel (cadr l)))
	  ((eqcar l 'LABEL) (saniere-Sprungziel (cadr l)))
	  (T l)))

 
(de rotate-right (n m)
    (lor
     (lsh n (minus m))
     (land 16#ffffffff (lsh n (difference 32 m)))))
		    
(de rotate-left (n m)
    (wor
     (wand 16#ffffffff (wshift n m))
     (wand 16#ffffffff (wshift n (wdifference m 32)))))
		    
(de decode-32bit-imm8-rotated (n)
    (for (from i 0 15 1)
	 (do
	  (if (equal (wand n 255) n)
	      (return (cons i n))
	    (setq n (rotate-left n 2))
	    )
	  )
	 )
    )

(de DepositInstructionBytes (byte1 byte2 byte3 byte4)
%    (printf "Deposit instruction %w at %x -> %x%n"
%	    (wor (wshift byte1 24) (wor (wshift byte2 16) (wor (wshift byte3 8) byte4)))
%	    CurrentOffset* (wplus2 CodeBase* CurrentOffset*))
    (if *big-endian*
	(progn
	  (DepositByte byte1)
	  (DepositByte byte2)
	  (DepositByte byte3)
	  (DepositByte byte4))
      (progn
	(DepositByte byte4)
	(DepositByte byte3)
	(DepositByte byte2)
	(DepositByte byte1)))
%    (printf "Deposited at %x: %x >%x< %x%n"
%	    (wplus2 (wplus2 CodeBase* CurrentOffset*) -4)
%	    (getword32 (wplus2 (wplus2 CodeBase* CurrentOffset*) -8) 0)
%	    (getword32 (wplus2 (wplus2 CodeBase* CurrentOffset*) -4) 0)
%	    (getword32 (wplus2 CodeBase* CurrentOffset*) 0)
%	    )
    )

%% Checks
(de OP-reg3 (code reg1 reg2 reg3)
    (DepositInstructionBytes
     (lsh (car code) -3)
     (lor (lsh (land (car code) 7) 5) (reg2int reg3))
     (lsh (reg2int reg2) -3)
     (lor (reg2int reg1) (lsh (land (reg2int reg2) 7) 5))))

(de lth-reg3 (code reg1 reg2 reg3) 4)

%% ChecK!
(de OP-reg-imm12 (code regd reg1 imm12-shifted)
    (let ((imm12 0) (sh) (opcode (car code)))
      (if (or (and (fixp imm12-shifted) (eq imm12-shifted (wand imm12-shifted 16#fff))
		   (setq imm12 imm12-shifted))
	      (and (pairp imm12-shifted) (pairp (cddr imm12-shifted)) (eq (caddr imm12-shifted) 0)
		   (setq imm12 (car imm12-shifted)))
	      )
	  (setq sh 0)
	(setq sh 1 imm12 (if (pairp imm12-shifted) (car imm12-shifted) (lsh imm12-shifted -12))))
      (DepositInstructionBytes
       (lsh opcode -1)
       (lor (lsh imm12 -6) (lor (lsh (land opcode 1) 7) (lsh sh 6)))
       (lor (lsh (land imm12 16#3f) 2) (lsh (reg2int reg1) -3))
       (lor (reg2int regd) (lsh (land (reg2int reg1) 7) 5))
       )))

(de lth-reg-imm12 (code reg1 imm12-shifted) 4)

(de OP-reg-xzr-imm12 (code reg1 imm12)
    (OP-reg-imm12 code
		  (list 'reg (if (reg32-or-sp-p reg1) 'Wzr 'Xzr))
		  reg1 imm12)
)

(de OP-reg-xzr-shifter (code reg1 reg-shifter)
    (OP-reg-shifter code (if (reg32p reg1) 'Wzr 'Xzr) reg1 reg-shifter))

(de OP-reg-xzr-extended (code reg1 reg-extended)
    (OP-reg-extended code (if (reg32p reg1) 'Wzr 'Xzr) reg1 reg-extended))

(de OP-reg-imm16 (code reg1 imm16-shifted)
    (let ((imm16 0) (sh) (opcode (car code)))
      (if (or (and (fixp imm16-shifted) (eq imm16-shifted (wand imm16-shifted 16#ffff))
		   (setq imm16 imm16-shifted))
	      (and (pairp imm16-shifted) (pairp (cddr imm16-shifted)) (eq (caddr imm16-shifted) 0)
		   (setq imm16 (caddr imm16-shifted))))
	  (setq sh 0)
	(setq sh 1))
      (cond ((fixp imm16-shifted)
	     (cond ((eq 0 imm16-shifted)
		    (setq sh 0) (setq imm16 0))
		   ((eq 0 (land imm16-shifted 16#ffffffffffff))
		    (setq sh 3)
		    (setq imm16 (lsh imm16-shifted -48)))
		   ((eq 0 (land imm16-shifted 16#ffffffff))
		    (setq sh 2)
		    (setq imm16 (lsh imm16-shifted -32)))
		   ((eq 0 (land imm16-shifted 16#ffff))
		    (setq sh 1)
		    (setq imm16 (lsh imm16-shifted -16)))
		   (t (setq sh 0) (setq imm16 imm16-shifted))))
	    (t (setq imm16 (car imm16-shifted))
	       (setq sh (lsh (caddr imm16-shifted) -4))))
      (DepositInstructionBytes
       (lsh opcode -1)
       (lor (lsh (land opcode 1) 7) (lor (land (lsh imm16 -11) 16#1f) (lsh sh 5)))
       (land 16#ff (lsh imm16 -3))
       (lor (reg2int reg1) (lsh (land imm16 7) 5))
       )))

(de lth-reg-imm16 (code reg1 reg2 imm16-shifted) 4)

(de OP-reg-logical (code regd regn imm-logical)
    (let ((opcode (car code))
	  (imm-part (imm-logical-p imm-logical)))
      (DepositinstructionBytes
       (lsh opcode -1)
       (lor (lsh (land opcode 1) 7) (lsh imm-part -6))
       (lor (lsh (land imm-part 16#3f) 2) (lsh (reg2int regn) -3))
       (lor (lsh (land (reg2int regn) 7) 5) (reg2int regd))
       )
      )
    )

(de lth-reg-logical (code regd regn imm-logical) 4)

(de OP-reg-regsp (code reg1 reg2)
    (OP-reg-imm12 code reg1 reg2 0)
    )

(de lth-reg-regsp (code reg1 reg2) 4)

(de OP-regsp-reg (code reg1 reg2)
    (OP-reg-imm12 code reg1 reg2 0)
    )

(de lth-regsp-reg (code reg1 reg2) 4)

(de OP-reg-reg (code reg1 reg2)
    (OP-reg-shifter code reg1 (if (reg32p reg1) 'Wzr 'Xzr) reg2)
    )

(de lth-reg-reg (code reg1 reg2) 4)

(de OP-regd-shifter (code regd reg-shifter)
    (OP-reg-shifter code regd (if (reg32p regd) 'Wzr 'Xzr) reg-shifter))

(de lth-regd-shifter (code regd reg-shifter) 4)

(de OP-reg-shifter (code reg1 reg2 reg-shifter)
    (prog (opcode2 shift-op shift-amount reg3)
	  (cond ((regp reg-shifter) (setq reg3 reg-shifter opcode2 (land (car code) 1) shift-amount 0))
		((eqcar reg-shifter 'regshifted)
		 (setq reg3 (list 'reg (cadr reg-shifter)) shift-op (caddr reg-shifter))
		 (setq shift-amount (cadddr reg-shifter))
		 (cond ((fixp shift-amount)
			(setq opcode2 (lor (land (car code) 1) (subla '((LSL . 2#000) (LSR . 2#010) (ASR . 2#100) (ROR . 2#110)) shift-op))))
		       (T (stderror (bldmsg "Invalid operand %w: shift amount = %w" reg-shifter shift-amount)))))
		(T (stderror (bldmsg "Invalid operand %w (shifted register)" reg-shifter))))
	  (DepositInstructionBytes
	   (lsh (car code) -3)
	   (lor (reg2int reg3) (lsh opcode2 5))
	   (lor (lsh (reg2int reg2) -3) (lsh shift-amount 2))
	   (lor (reg2int reg1) (lsh (land (reg2int reg2) 7) 5))))
                                                                            
    )

(de lth-reg-shifter (code reg1 reg2 reg-shifter) 4)

(de OP-reg-extended (code reg1 reg2 reg-extended)
    (prog (option reg3 shift-op extend-amount extend-bits)
	  (cond ((regp reg-extended)
		 (setq reg3 reg-extended)
		 (setq extend-amount 0 option (if (reg32p reg1) 2#010 2#011)))
		((eqcar reg-extended 'regextended)
		 (setq reg3 (list 'reg (cadr reg-extended))
		       shift-op (caddr reg-extended))
		 (if (pairp (cdddr reg-extended))
		     (setq extend-amount (cadddr reg-extended))
		   (setq extend-amount 0))
		 (cond ((fixp extend-amount)
			(if (eq shift-op 'LSL)
			    (setq extend-bits (if (reg32p reg1) 2#010 2#011))
			  (setq extend-bits (subla '((UXTB . 2#000) (UXTH . 2#001) (UXTW . 2#010) (LSL . 2#011) (UXTX . 2#011) (SXTB . 2#100) (SXTH . 2#101) (SXTW . 2#110) (SXTX . 2#111)) shift-op)))
			(setq option (lor (lsh (land extend-amount 1) 3) extend-bits)))
		       (T (stderror (bldmsg "Invalid operand %w: extend amount = %w" reg-extended extend-amount)))))
		(T (stderror (bldmsg "Invalid operand %w (extended register)" reg-extended))))
	  (DepositInstructionBytes
	   (lsh (car code) -3)
	   (lor (reg2int reg3) (lsh (land (car code) 3) 5))
	   (lor (lor (lsh (reg2int reg2) -3) (lsh extend-amount 2)) (lsh option 5))
	   (lor (reg2int reg1) (lsh (land (reg2int reg2) 7) 5))))
                                                                            
    )

(de lth-reg-extended (code reg1 reg2 reg-extended) 4)

%% (de OP-regn-imm8 (code regn imm8-rotated)
%%     (prog (cc opcode1 imm8-decoded set-bit)
%% 	  (setq imm8-decoded (decode-32bit-imm8-rotated imm8-rotated))
%% 	  (if (null imm8-decoded)
%% 	      (stderror (bldmsg "Invalid imm8 operand %w" imm8-rotated)))
%% 	  (setq cc (car code) opcode1 (cadr code) set-bit (caddr code))
%% 	  (DepositInstructionBytes
%% 	   (lor (lsh cc 4) (lsh opcode1 -3))
%% 	   (lor (lor (lsh (land opcode1 2#111) 5) (lsh set-bit 4)) (reg2int regn))
%% 	   (car imm8-decoded)
%% 	   (cdr imm8-decoded)))
%%     )

%% (de lth-regn-imm8 (code regn imm8-rotated) 4)

%% (de OP-regn-shifter (code regn reg-shifter)
%%     (prog (cc opcode1 opcode2 set-bit reg3 reg4 shift-op shift-amount)
%% 	  (setq cc (car code) opcode1 (cadr code) set-bit (caddr code) shift-amount 0)
%% 	  (cond ((regp reg-shifter) (setq reg3 (reg2int reg-shifter) reg4 0 opcode2 0))
%% 		((eqcar reg-shifter 'regshifted)
%% 		 (setq reg3 (reg2int (cadr reg-shifter)) shift-op (caddr reg-shifter))
%% 		 (if (eq shift-op 'RRX)
%% 		     (setq shift-amount 0)
%% 		   (setq shift-amount (cadddr reg-shifter)))
%% 		 (cond ((and (fixp shift-amount)
%% 			     (greaterp shift-amount -1)
%% 			     (lessp shift-amount 33))
%% 			(setq shift-amount (land 31 shift-amount))
%% 			(setq reg4 (lsh shift-amount -1)
%% 			      opcode2 (lor (lsh (land shift-amount 1) 3) (subla '((LSL . 2#000) (LSR . 2#010) (ASR . 2#100) (ROR . 2#110) (RRX . 2#110)) shift-op))))
%% 		       ((regp shift-amount)
%% 			(setq reg4 (reg2int (cadddr reg-shifter)))
%% 			(setq opcode2 (subla '((LSL . 2#0001) (LSR . 2#0011) (ASR . 2#0101) (ROR 2#0111)) shift-op))
%% 			)
%% 		       (T (stderror (bldmsg "Invalid operand %w" reg-shifter)))))
%% 		(T (stderror (bldmsg "Invalid operand %w" reg-shifter))))
%% 	  (DepositInstructionBytes
%% 	   (lor (lsh cc 4) (lsh opcode1 -3))
%% 	   (lor (lor (lsh (land opcode1 2#111) 5) (lsh set-bit 4)) (reg2int regn))
%% 	   reg4
%% 	    (lor (lsh opcode2 4) reg3)))
%%     )

%% (de lth-regn-shifter (code regn reg-shifter) 4)

%% (de OP-regd-imm8 (code regd imm8-rotated)
%%     (prog (cc opcode1 imm8-decoded set-bit)
%% 	  (setq imm8-decoded (decode-32bit-imm8-rotated imm8-rotated))
%% 	  (if (null imm8-decoded)
%% 	      (stderror (bldmsg "Invalid imm8 operand %w" imm8-rotated)))
%% 	  (setq cc (car code) opcode1 (cadr code) set-bit (caddr code))
%% 	  (DepositInstructionBytes
%% 	   (lor (lsh cc 4) (lsh opcode1 -3))
%% 	   (lor (lsh (land opcode1 2#111) 5) (lsh set-bit 4))
%% 	   (lor (lsh (reg2int regd) 4) (car imm8-decoded))
%% 	   (cdr imm8-decoded)))
%%     )

%% (de lth-regd-imm8 (code regd imm8-rotated) 4)

(de OP-mov-imm16 (code reg1 imm16)
    (prog (cc opcode1)
	  (setq cc (car code) opcode1 (cadr code))
	  (DepositInstructionBytes
	   (lor (lsh cc 4) (lsh opcode1 -4))
	   (lor (lsh (land opcode1 2#1111) 4) (lsh imm16 -12))
	   (lor (lsh (reg2int reg1) 4) (land 2#1111 (lsh imm16 -8)))
	   (land 16#ff imm16)))
    )

(de lth-mov-imm16 (code reg1 imm16) 4)

(de OP-mul3 (code reg1 reg2 reg3)
    (op-mul4 code reg1 reg2 reg3 (caddr code)))

(de lth-mul3 (code reg1 reg2 reg3) 4)
		       
(de OP-mul4 (code regd regn regm rega)
    (prog (cc opcode1)
	  (setq cc (car code) opcode1 (cadr code))
	  (DepositInstructionBytes
	   (lsh cc -3)
	   (lor (lsh (land cc 7) 5) (reg2int regm))
	   (lor (lsh opcode1 7)
		(lor (lsh (reg2int regn) -3) (lsh (reg2int rega) 2)))
	   (lor (lsh (land (reg2int regn) 7) 5) (reg2int regd)))))

(de lth-mul4 (code reg1 reg2 reg3 reg4) 4)

(de OP-clz (code regd regn)
    (prog (cc opcode1 opcode2 reg3 reg4 shift-op shift-amount set-bit)
	  (setq cc (car code) opcode1 (cadr code) opcode2 (cadddr code))
	  (DepositInstructionBytes
	   (lsh cc -3)
	   (lor opcode1 (lsh (land cc 7) 5))
	   (lor (lsh (reg2int regn) -3) (lsh opcode2 2))
	   (lor (lsh (land (reg2int regn 7) 5) (reg2int regd)))
	  )
    ))

(de lth-clz (code regd regm) 4)

%% ToDo
(de OP-streg (code regd cpsr-or-spsr)
    (prog (cc opcode1 opcode2 reg3 reg4 shift-op shift-amount set-bit r)
	  (cond ((eq cpsr-or-spsr 'cpsr) (setq r 0))
		((eq cpsr-or-spsr 'spsr) (setq r 1))
		(t (stderror (bldmsg "Invalid MRS operand: %w" cpsr-or-spsr))))
	  (setq cc (car code) opcode1 (cadr code) set-bit (caddr code) opcode2 (cadddr code))
	  (DepositInstructionBytes
	   (lsh cc -4)
	   (lor (lsh r 6) 2#01111)
	   (lor (lsh (reg2int regd) 4) 2#0000)
	   (lsh opcode2 4))
	  )
    )

(de lth-streg (code regd regm) 4)


%%  Instruction                                      Lisp expression for second operand
%% LDR Rt,[Rn]                                         (indirect (reg n))
%% LDR Rt,[Rn,+/-offset12words]                        (displacement (reg n) +/-14/15bit-number)
%% LDR Rt,[Rn,Rm]                                      (displacement (reg n) (reg m))
%% LDR Rt,[Rn,Rm, shift, #shift_imm]                   (displacement (reg n) (regshifted <regno> LSL amount))
%% LDR Rt,[Rn,Rm, extend, #shift_imm]                  (displacement (reg n) (regextended <regno> UXTW/SXTW/SXTX amount))
%% LDR Rt,[Rn,+/-offset8]!                             (preindexed (reg n) +/-8bit-number)
%% LDR Rt,[Rn],+/-offset8                              (postindexed (reg n) +/-8bit-number)

(de OP-ld-st (code regt reg-offset)
    (prog (opcode1 s-bit size shift-op shift-amount regn displ offset pre-post ppbits regm byte1 byte2 byte3 lastbyte)
	  (setq opcode1 (car code) shift-amount 0)
	  (if (and
	       (not (labelp reg-offset))
	       (or (not (pairp reg-offset))
	       	   (not (memq (car reg-offset) '(displacement indirect indexed preindexed postindexed)))
		   (not (reg-or-sp-p (cadr reg-offset)))))
	      (stderror (bldmsg "Invalid 1 LDR/STR operand: %w" reg-offset)))
	  (if (labelp reg-offset)	% label --> pc-relative
	      (progn
		(setq byte1 opcode1)
		(setq displ (MakeExpressionRelative reg-offset 0))
		(setq byte2 (land 16#ff (lsh displ -13)))
		(setq byte3 (land 16#ff (lsh displ -5)))
		(setq lastbyte (lor (land 16#e0 (lsh displ 3)) (reg2int regt)))
	      )
	    (progn
	      (setq regn (reg2int (cadr reg-offset)))
	      (setq size (lsh opcode1 -9))
	      (setq displ (if (eqcar reg-offset 'indirect) 0 (caddr reg-offset)))
	      ))
	  (cond ((or (labelp reg-offset)
		     (not (memq (car reg-offset) '(indexed indirect displacement preindexed postindexed)))
		     )
		 nil)
		((and (memq (car reg-offset) '(preindexed postindexed))
		      (fixp displ) (lessp displ 256) (greaterp displ -257))
		 (setq pre-post (car reg-offset))
		 (setq ppbits (cadr code))
		 (setq displ (land displ 2#111111111)) % mask to nine bits
		 (setq lastbyte (lor (lsh (land 2#111 regn) 5) (reg2int regt)))
		 (setq byte3 
		       (lor (lsh regn -3)
			    (lor (lsh ppbits 2)
				 (lsh (land displ 2#1111) 4))))
		 (setq byte2
		       (lor (lsh displ -4)
			    (lsh (land opcode1 2#111) 5)))
		 (setq byte1 (lsh opcode1 -3)))
		
		((and (eq (car reg-offset) 'displacement) (fixp displ))
		 (setq size (lsh opcode1 -8))
		 (if (or (and (eq size 2#10) (eq (land 2#11 displ) 0)
			      (pos-twelve-bit-p (setq displ (lsh displ -2))))
			 (and (eq size 2#11) (eq (land 2#111 displ) 0)
			      (pos-twelve-bit-p (setq displ (lsh displ -3))))
			 (and (eq size 2#01) (eq (land 2#1 displ) 0)
			      (pos-twelve-bit-p (setq displ (lsh displ -1))))
			 (and (eq size 2#00)
			      (pos-twelve-bit-p displ)))
		     (progn
		       (setq lastbyte (lor (lsh (land 2#111 regn) 5) (reg2int regt)))
		       (setq byte3 (lor (lsh regn -3) (lsh (land displ 2#111111) 2)))
		       (setq byte2 (lor (lsh displ -6) (lsh (land opcode1 2#11) 6)))
		       (setq byte1 (lsh opcode1 -2)))
		   (stderror (bldmsg "Invalid 2 LDR/STR operand: %w" reg-offset))))
		((and (eq (car reg-offset) 'indirect) (null (cddr reg-offset)))
		 % like previous case with displacement = 0
		 (setq lastbyte (lor (lsh (land 2#111 regn) 5) (reg2int regt)))
		 (setq byte3  (lsh regn -3))
		 (setq byte2 (lsh (land opcode1 2#11) 6))
		 (setq byte1 (lsh opcode1 -2)))
		((or (not (pairp displ))
		     (not (memq (car displ) '(reg regshifted regextended))))
		 (stderror (bldmsg "Invalid 3 LDR/STR operand: %w" reg-offset)))
                % check for (scaled) register offset
		((or (and (eq (car reg-offset) 'indexed) (regp displ))
		     (and (eq (car displ) 'regshifted)
			  (eq (caddr displ) 'LSL))
		     (and (eq (car displ) 'regextended)
			  (memq (caddr displ) '(UXTW SXTW SXTX))))
		 (if (not (or (regp displ) (memq (cadddr displ) (list 0 size))))
		     (stderror (bldmsg "Invalid 4 LDR/STR operand: %w" reg-offset)))
		 (if (regp displ)
		     (progn
		       (setq regm (reg2int displ))
		       (setq shift-op 'LSL)
		       (setq S-bit 0)
		       (setq shift-amount 0))
		   (progn
		     (setq regm (reg2int (list 'reg (cadr displ))))
		     (setq shift-op (if (cddr displ) (caddr displ) 'LSL))
		     (setq S-bit (if (cddr displ) 1 0))
		     (setq shift-amount (cadddr displ))))
		 (setq lastbyte (lor (lsh (land 2#111 regn) 5) (reg2int regt)))
		 (setq byte3 
		       (lor (lsh regn -3)
			    (lor (lsh (cadr code) 2)
				 (lor (lsh S-bit 4)
				      (lsh (subla '((LSL . 2#011) (UXTW . 2#010) (SXTW . 2#110) (SXTX . 2#111)) shift-op) 5)))))
		 (setq byte2
		       (lor (lsh (land opcode1 2#111) 5) regm))
		 (setq byte1 (lsh opcode1 -3)))
		(t (stderror (bldmsg "Invalid 5 LDR/STR operand: %w" reg-offset))))
	  (DepositInstructionBytes
	   byte1
	   byte2
	   byte3
	   lastbyte)
    ))


(de lth-ld-st (code regn reg-offset12) 4)

%% (de OP-ldr-id (code regn idref)
%%     (OP-ld-st code regn idref)
%%     )

%% (de lth-ldr-id (code regn idref) 4)


%% (de OP-ld-st-misc (code regd reg-offset8)
%%     (prog (cc ld-bit opcode1 opcode2 temp shift-op shift-amount regn displ pre-post p-bit u-bit w-bit regm lastnibble)
%% 	  (setq cc (car code) opcode1 (cadr code) ld-bit (caddr code) opcode2 (cadddr code) shift-amount 0)
%% 	  (if (or (not (pairp reg-offset8))
%% 		  (not (memq (car reg-offset8) '(displacement indirect)))
%% 		  (not (regp (cadr reg-offset8))))
%% 	      (stderror (bldmsg "Invalid misc. load/store operand %w" reg-offset8)))
%% 	  (setq regn (reg2int (cadr reg-offset8)))
%% 	  (setq displ (if (eqcar reg-offset8 'indirect) 0 (caddr reg-offset8)))
%% 	  (setq u-bit 1)
%% 	  (cond ((or (eqcar reg-offset8 'indirect)
%% 		     (null (cdddr reg-offset8))) % no pre or post indexed
%% 		 (setq p-bit 1 w-bit 0))
%% 		((memq (cadddr reg-offset8) '(preindexed postindexed))
%% 		 (setq pre-post (cadddr reg-offset8))
%% 		 (setq p-bit (if (eq pre-post 'preindexed) 1 0))
%% 		 (setq w-bit (if (eq pre-post 'preindexed) 1 0)))
%% 		(t (stderror (bldmsg "Invalid misc. load/store operand: %w" reg-offset8))))
%% 	  (cond ((and (fixp displ) (lessp displ 256) (greaterp displ -256))
%% 		 (if (lessp displ 0)
%% 		     (progn
%% 		       (setq u-bit 0)
%% 		       (setq displ (minus displ)))
%% 		   (setq u-bit 1))
%% 		 (setq temp (lsh displ -4))
%% 		 (setq lastnibble (land displ 16#0F)))
%% 		((or (not (pairp displ))
%% 		     (not (memq (car displ) '(reg plus minus))))
%% 		 (stderror (bldmsg "Invalid misc. load/store operand: %w" reg-offset8)))
%% 		((or (regp displ)
%% 		     (and (memq (car displ) '(plus minus))
%% 			  (progn (if (eq (car displ) 'minus) (setq u-bit 0))
%% 				 (regp (setq displ (cadr displ))))))
%% 		 (setq temp 0)
%% 		 (setq lastnibble (reg2int displ)))
%% 		(t (stderror (bldmsg "Invalid misc. load/store operand: %w" reg-offset8))))
%% 	  (DepositInstructionBytes
%% 	   (lor (lor (lsh cc 4) (lsh opcode1 -3)) p-bit)
%% 	   (lor (lor (lsh u-bit 7) (lsh (land opcode1 2#111) 5) ) (lor (lsh w-bit 5) (lor (lsh ld-bit 4) regn)))
%% 	   (lor (lsh (reg2int regd) 4) temp)
%% 	   (lor (lshift opcode2 4) lastnibble)))
%% )

%% (de lth-ld-st-misc (code regn reg-offset8) 4)

(de OP-ldp-stp (code regt1 regt2 reg-or-sp-imm)
    (prog (opcode1 imm regn)
	  (setq opcode1 (car code))
	  (setq regn (reg2int (cadr reg-or-sp-imm)))
	  (if (eq (car reg-or-sp-imm) 'indirect)
	      (setq imm 0)
	    (setq imm (land 16#7f (lsh (caddr reg-or-sp-imm) (if (reg32p regt1) -2 -3)))))
	  (DepositInstructionBytes
	   (lsh opcode1 -2)
	   (lor (lsh (land opcode1 2#11) 6) (lsh imm -1))
           (lor (lor (lsh (land imm 1) 7) (lsh (reg2int regt2) 2)) (lsh regn -3))
           (lor (reg2int regt1) (lsh (land regn 2#111) 5)))
    ))

(de lth-ldp-stp (code regt1 regt2 reg-or-sp-imm) 4)

(de OP-fcvt (code regd regn)
    (prog (opcode1 opcode2)
	  (setq opcode1 (car code) opcode2 (cadr code))
	  (DepositInstructionBytes
	   (lsh opcode1 -3)
	   (lor (lsh (land opcode1 2#111) 5) opcode2)
	   (lsh (reg2int regn) -3)
           (lor (reg2int regd) (lsh (land (reg2int regn) 2#111) 5)))
    ))

(de lth-fcvt (code regd regn) 4)

(de OP-fp-arith (code regd regn regm)
    (prog (opcode1 opcode2)
	  (setq opcode1 (car code) opcode2 (cadr code))
	  (DepositInstructionBytes
	   (lsh opcode1 -3)
	   (lor (lsh (land opcode1 2#111) 5) (reg2int regm))
	   (lor (lsh opcode2 2) (lsh (reg2int regn) -3))
           (lor (reg2int regd) (lsh (land (reg2int regn) 2#111) 5)))
    ))

(de lth-fp-arith (code regd regn regm) 4)

(de OP-fcmp (code regn regm)
    (OP-fp-arith code '(reg d0) regn regm))

(de lth-fcmp (code regd regn) 4)

(de OP-nop (code)
    (DepositInstructionBytes 16#d5 16#03 16#20 16#1f))

(de lth-nop (code) 4)

% ------------------------------------------------------------
% standard operand tags
% ------------------------------------------------------------

(de ForceAlignment nil
    % align to quadword boundary
    (while (not (eq 0 (remainder CurrentOffset!* 4)))
      (DepositByte 0))
    (if (not (eq 0 (remainder CurrentOffset!* 8)))
      (OP-nop nil)))

(de DepositFluid (X)
    (DepositValueCellLocation (second X)))      % Defined in System-Faslin.Red

(de DepositExtraReg (X)
    (DepositExtraRegLocation (second X)))       % Defined in System-Faslin.Red

(de DepositEntry (X)
    (DepositFunctionCellLocation (second X)))   % Defined in System-Faslin.Red

(de depositforeignentry (x)
    (depositfunctioncelllocation (second x)))

%(flag '(fluid $fluid global $global ExtraReg entry foreignentry) 'ForceAlignment)

(put 'fluid 'OperandDepositFunction (function DepositFluid))
(put '$fluid 'OperandDepositFunction (function DepositFluid))
(put 'global 'OperandDepositFunction (function DepositFluid))
(put '$global 'OperandDepositFunction (function DepositFluid))
(put 'ExtraReg 'OperandDepositFunction (function DepositExtraReg))
(put 'entry 'OperandDepositFunction (function DepositEntry))
(put 'foreignentry 'operanddepositfunction (function depositforeignentry))
 


% ------------------------------------------------------------
% Deposit instructions for Pseudo ops
% ------------------------------------------------------------

(de DepositWordBlock (X)                % (FULLWORD xxx xxx ... xxx)
    (foreach Y in (cdr X) do (DepositQuadWordExpression Y)))

(de DepositHalfWordBlock (X)            % (HALFWORD xxx xxx ... xxx)
    (foreach Y in (cdr X) do (DepositHalfWordExpression Y)))

(de DepositByteBlock (X)                % (BYTE     xxx xxx ... xxx)
(prog (Z) 
    (setq Z 0) 
    (foreach Y in (cdr X) do 
    (progn (DepositByte Y) 
	(setq Z (LXOR Z 1))))           % toggle Z
    (cond ((not (equal Z 0)) (DepositByte 0)))))        % go to halfword boundary


% Deposit a string with a trailing ZERO byte

(de DepositString (X)                   % (STRING "xxxxxx")
  (prog nil 
    (setq X (second X)) 
    (for (from I 0 (Size X) 1) (do (DepositByte (Indx X I)))) 
    (DepositByte 0)
    (while (not (eq 0 (remainder CurrentOffset!* 8)))
      (DepositByte 0))))		% align to word boundary

(de DepositFloat (X)                    % this will not work in cross-assembly
    (progn
      (setq X (FltInf (second X))) 
      (DepositWord (FloatlowOrder X))))

(put 'fullword 'InstructionDepositFunction 'DepositWordBlock)
(put 'halfword 'InstructionDepositFunction 'DepositHalfWordBlock)
(put 'byte 'InstructionDepositFunction 'DepositByteBlock)
(put 'string 'InstructionDepositFunction 'DepositString)
(put 'float 'InstructionDepositFunction 'DepositFloat)

%(flag '(fullword string float) 'ForceAlignment)

(de AddLapComment (X)
    (setq lapcomment* (cdr X))
    )

(put 'comment 'InstructionDepositFunction 'AddLapComment)
(put 'samelinecomment 'InstructionDepositFunction 'AddLapComment)

(de DepositLoadAddress (X)
    (prog (src dest rel)
	  (setq src (caddr X) dest (cadr X))
	  (cond ((or (not (or (idp src) (stringp src))) (not (regp dest)))
		 (stderror (bldmsg "Invalid ADRL pseudo-op: %w" X)))
		(t
		 (setq rel (MakeExpressionRelative src 8))
%		 (print (list src dest rel))
		 (cond ((lessp rel 0)
			(setq rel (minus rel))
			(cond ((imm8-rotatedp rel)
			       (DepositInstruction `(SUB ,dest (reg pc) ,rel))
			       (DepositInstruction '(MOV (reg 1) (reg 1))))
			      ((lessp rel 16#10000)
			       (DepositInstruction `(SUB ,dest (reg pc) ,(wand 16#ff rel)))
			       (DepositInstruction `(SUB ,dest ,dest ,(wand 16#ff00 rel))))
			      ((and (eq 0 (wand rel 3)) % divisible by 4
				    (imm8-rotatedp (wand rel 16#fffffc00)))
			       (DepositInstruction `(SUB ,dest (reg pc) ,(wand 16#3ff rel)))
			       (DepositInstruction `(SUB ,dest ,dest ,(wand 16#fffffc00 rel))))
			      ((and (eq 0 (wand rel 7)) % divisible by 8
				    (imm8-rotatedp (wand rel 16#fffff800)))
			       (DepositInstruction `(SUB ,dest (reg pc) ,(wand 16#7ff rel)))
			       (DepositInstruction `(SUB ,dest ,dest ,(wand 16#fffff800 rel))))
			      (t (stderror (bldmsg "ADRL load too far: %w" rel)))))
		       ((imm8-rotatedp rel)
			(DepositInstruction `(ADD ,dest (reg pc) ,rel))
			(DepositInstruction '(MOV (reg 1) (reg 1))))
		       ((lessp rel 16#10000)
			(DepositInstruction `(ADD ,dest (reg pc) ,(wand 16#ff rel)))
			(DepositInstruction `(ADD ,dest ,dest ,(wand 16#ff00 rel))))
		       ((and (eq 0 (wand rel 3)) % divisible by 4
			     (imm8-rotatedp (wand rel 16#fffffc00)))
			(DepositInstruction `(ADD ,dest (reg pc) ,(wand 16#3ff rel)))
			(DepositInstruction `(ADD ,dest ,dest ,(wand 16#fffffc00 rel))))
		       ((and (eq 0 (wand rel 7)) % divisible by 8
			     (imm8-rotatedp (wand rel 16#fffff800)))
			(DepositInstruction `(ADD ,dest (reg pc) ,(wand 16#7ff rel)))
			(DepositInstruction `(ADD ,dest ,dest ,(wand 16#fffff800 rel))))
		       (t (stderror (bldmsg "ADRL load too far: %w" rel)))))
		)))

(put 'ADRL 'InstructionDepositFunction 'DepositLoadAddress)

%(put 'ADR 'InstructionLength 4)
(put 'ADRL 'InstructionLength 8)

(de DepositFarLoadAddress (X)
    (prog (src dest)
	  (setq src (caddr X) dest (cadr X))  
	  (cond ((or (not (or (idp src) (stringp src))) (not (regp dest)))
		 (stderror (bldmsg "Invalid LDR!= pseudo-op: %p" X)))
		(t
		 (DepositLoadAddress `(ADRL ,dest ,src))
		 (DepositInstruction `(LDR ,dest (indirect ,dest)))))))

(put 'LDR!= 'InstructionDepositFunction 'DepositFarLoadAddress)

(put 'LDR!= 'InstructionLength 12)

% Auxiliary functions for computing instruction bit patterns

(de MakeExpressionRelative (Exp OffsetFromHere) 
(prog (X Y Z) 
    (cond ((EqCar Exp 'InternalEntry) 
      (return (MakeInternalEntryRelative (second Exp) OffsetFromHere)))) 

    (cond ((not (LabelP Exp))
	   (return (StdError "Only labels can be relative")))) 

    (setq X (plus CurrentOffset* OffsetFromHere)) 
    (setq Y (LabelOffset Exp))
    (return (Difference Y X))))


(de MakeInternalentryRelative (nam offsetfromhere)
  (prog (offset)
	(setq offset (atsoc nam LabelOffsets*))
	(setq offset (if offset
		(cdr offset)
		(get nam 'internalentryoffset)))
	(return (if offset
		  (progn
		    (setq offset 
		     (difference offset 
		      (plus2 CurrentOffset* offsetfromhere))))
		  (progn
		    (setq ForwardInternalReferences* 
		     (cons (cons CurrentOffset* nam) 
		      ForwardInternalReferences*))
		    0)))))
	% will be fixed in SystemFasl...


(de LabelOffset (l)
  (let (offset)
    (cond 
     ((codep l) (if *writingfaslfile
		  (inf l)
		  (wdifference (inf l) CodeBase*)))
     ((setq offset  (atsoc l LabelOffsets*)) (cdr offset))
     (t (stderror (bldmsg "Unknown label %r" l)))
     )))



% ------------------------------------------------------------
% Branch analysis (conditional jumps)
% ------------------------------------------------------------

(fluid '(ConditionalJumps*))
(setq ConditionalJumps* 
  '((B!.EQ  . B!.NE)  (B!.NE  . B!.EQ)
    (B!.CS  . B!.CC)  (B!.CC  . B!.CS)
    (B!.MI  . B!.PL)  (B!.PL  . B!.MI)
    (B!.VS  . B!.VC)  (B!.VC  . B!.VS)
    (B!.HI  . B!.LS)  (B!.LS  . B!.HI)
    (B!.GE  . B!.LT)  (B!.LT  . B!.GE)
    (B!.GT  . B!.LE)  (B!.LE  . B!.GT)
))

(de ReformBranches (code)
  (prog (rcode instr bottom x y z)
    (while code
       (setq instr (pop code))
	   % replace simple negation jumps
	   % case: (jne lab)(j anywhere) lab
	   %  ->   (je anywhere)
       (when (and 
		(pairp instr)
		(setq x (atsoc (car instr) ConditionalJumps*))
		(setq y (saniere-Sprungziel (cadr instr)))
		(eqcar (car code) 'B)
		(cdr code)
		(equal (cadr code) y))
	     (setq instr (cons (cdr x) (cdr (pop code)))))
	   % replace indirect conditional jumps (not avail on 386)
	(when (and
		(pairp instr)
		(atsoc (car instr) ConditionalJumps*)
		(not (atom (saniere-Sprungziel (cadr instr)))))
	     (setq x (gensym))
	     (push (cons 'B (cdr instr)) bottom)
	     (push x bottom)
	     (setq instr (list (car instr) x))   )
	(push instr rcode))
	(return (nconc (reversip rcode) bottom))))
 
%% ------------------------------------------------------------
%% Branch optimization (in favour of short jumps)
%% ------------------------------------------------------------
%
%(de GeneralBranchInstructionP (i) (get i 'WordBranch))

(de GeneralLDRInstructionP (i) (eq i 'LDR))

(de LocalLabelp (l) (atom (saniere-Sprungziel l)))

% ProcessInitCode CodeList
% Purpose: Take a code list which has already been expanded by Pass1Lap
%          and replaces all generic branches with word mode branches.
% Returns: a new code list

(de ProcessInitCode (CodeList) 
(prog (BranchAndLabelAList*)            % find branches, labels, and entries
    (setq CodeList (BuildInitCodeOffsetTable CodeList)) 
    (setq LabelOffsets* (DeleteAllButLabels BranchAndLabelAList*)) 
    (return CodeList)))


% OptimizeBranches BranchCodeList!*;
% Purpose: Take a code list which has already been expanded by Pass1Lap
%          and look for LDR instructions where the source memory address outside
%          the $pc+/-4096 range. E.g.
%
%          (LDR (reg xy) "l0123")
%          ...
%          l0123
%          (fullword something)
%
%          where l0123 is more that 4096 away from the LDR instruction.
%
% 1. Approach:
%          Replace this by
%
%          (BL l4567)
%          ...
%          l4567
%          (LDR (reg xy) "l0123")
%          (BX (REG LR))
%          l0123
%          (fullword something)
%
%          since branches have a 26 bit offset.
%          The BL instruction stores the return address into register lr, so that
%          the BX instruction jumps back to the address immediately following.
%
%   Disadvantage: a simple load is replaced by jump-load-jump. 
%
% 2. Approach:
%          Let n be the offset between the original load instruction and the target of the
%          load. (This means that n is a multiple of 4).
%          Replace the original LDR by the LDR!= pseudo instruction:
%
%          (LDR!= (reg xy) "l0123")
%
%          which expands to
%
%          (ADRL (reg xy) "l0123")
%          (LDR (reg xy) (indirect (reg xy)))
%
%          Assuming that n>0, the ADRL pseudo instruction expands in turn
%          to the following pair of instructions:
%
%          (ADD (reg xy) (reg pc) n1)
%          (ADD (reg xy) (reg xy) n2)
%
%          with n1 = (n & 0x3ff) and n2 = (n & 0x3fc00), provided that n is an 18bit offset, i.e. +/-256kB.
%
%          For negative n, replace n by (-n) and ADD by SUB. See the definition of the ADRL
%          pseudo instruction below for more information.
%%
% Returns: a new code list



(de OptimizeBranches (u) 
(prog (BranchAndLabelAList* InstructionChanged* q w) 
    (setq BranchCodeList* (alignData u))
    (BuildOffsetTable)                  % find branches, labels, and entries
    (setq InstructionChanged* nil)
    (setq LabelOffsets* (DeleteAllButLabels BranchAndLabelAList*)) 
    (return BranchCodeList*)))

(de alignData(u)
    (let(rcode
	 w
	 (offset (or CurrentOffset* 0))
	 prev-op
	 offset1
	 in-code?
	 nops)
      (while u
       (setq prev-op w)
       (setq w (pop u))
       (setq nops 0)
       (cond 

	 % initial start: sync. entry point
%%	   ((null rcode)
%% 	    (setq offset1 offset)
%% 	    (let ((y u) (q w))
%% 	      (setq in-code? (eqcar w '*entry))
%% 	      (while y
%% 		(when (pairp q)(setq offset1 (iplus2 offset1 (instructionlength q))))
%% 		(if (eqcar q '*entry) (setq y nil) (setq q (pop y))))
%% 	      (setq offset1 (wand offset1 7))
%% 	      (when (not (eq offset1 0))
%% 		(push '(nop) rcode)
%% 		(setq offset (iplus2 offset 4)))
%% 	      )
%%	    )
	   
 
	% entry: executable code starts
	    ((eqcar w '*entry)(setq in-code? t))
	    
	% fullword: executable code terminated
	((eqcar w 'fullword)
	 (setq in-code? nil)
	 (setq offset1 (wand offset 7))
	 (when (not (eq offset1 0))
	   % insert nop for 8 byte alignment
	   % check if preceded by label, push label after alignment
	   (let (q)
	     (if (and (pairp rcode) (labelp (car rcode)))
		 (setq q (pop rcode)))
	     (push '(nop) rcode)
	     (setq offset (iplus2 offset 4))
	     (if q (push q rcode)))
	   )
	 (setq offset (iplus2 offset 8))
	 )

	% label in data
	   ((and (not in-code?) (labelp w))
 	    (setq offset1 (wand offset 7))
 	    (when (not (eq offset1 0))
	      (push '(nop) rcode)
	      (setq offset (iplus2 offset 4)))
	    )
	       
	 )
       (when (pairp w)(setq offset (iplus2 offset (InstructionLength w))))
%       (print (list offset w))
       (push w rcode)
       )
      % Now at end: if we are in code, check for alignment and issue nop if necessary
      (when (and in-code? (not (eq 0 (wand offset 7))))
	(push '(nop) rcode)
	(setq offset (iplus2 offset 4)))
      (setq u (reversip rcode))

    u      
))

(de DeleteAllButLabels (X) 
(prog (Y) 
   (while (and X (not (LabelP (car (first X))))) (setq X (cdr X))) 

   (cond ((null X) (return nil))) 
    (setq Y X) 
    (while (cdr Y) 
	(cond ((LabelP (car (second Y))) 
	    (setq Y (cdr Y))) (t 
	
	    (Rplacd Y (cddr Y))))) 
    (return X)))


% BuildInitCodeOffsetTable CodeList;
% Purpose: generate a association list of labels, procedure entries
% Input is:
     %   labels:             label
     %   instructions:     ( opcode [operands]* )
     %   entry points:     ( !*entry procedurename proceduretype numberofargs)
% The Alist has the form:
     %   labels:           ( label . CurrentOffset)
     %   procedures:       ( procedurename . CurrentOffset)
     %   branch instrs     ( (opcode label) . CurrentOffset)
     %   LDR instrs        ( (opcode dest label) . CurrentOffset)
% otherwise, the CurrentOffset is advanced by the length of the instruction

(de BuildInitCodeOffsetTable (CodeList) 
(prog (AList Instr) 
    (setq CodeSize* CurrentOffset*) 
    (foreach X in CodeList do 
   (progn (cond ((LabelP X) 
	  (setq AList (cons (cons X CodeSize*) AList))) 
   ((equal (setq Instr (first X)) '*entry) 
	  (setq AList (cons (cons (second X) CodeSize*) AList))) 
   ((and (GeneralLDRInstructionP Instr) (LocalLabelp (third X)))
           (setq AList (cons (cons X CodeSize*) AList)))
		
   (t
    (if (and (flagp (first X) 'ForceAlignment)
	     (not (eq 0 (remainder CodeSize* 8))))
	(setq CodeSize* (plus CodeSize* (difference 8 (remainder CodeSize* 8)))))
    (setq CodeSize* (plus CodeSize* (InstructionLength X)))))))
    
    (setq BranchAndLabelAList* (ReversIP AList))
    (return CodeList)))


%  BuildOffsetTable();
% Purpose: generate a association list of labels, procedure entries
% The Alist has the form:
     %   labels:           ( label . CurrentOffset)
     %   procedures:       ( procedurename . CurrentOffset)
     %   branch instrs     ( (opcode label) . CurrentOffset)
     %   LDR instrs        ( (opcode dest label) . CurrentOffset)

(de BuildOffsetTable nil 
 (prog (AList Instr) 
  (setq CodeSize* CurrentOffset*) 
  (foreach X in BranchCodeList* do 
   (progn 
     (cond ((LabelP X) (setq AList (cons (cons X CodeSize*) AList))) 
	   ((equal (setq Instr (first X)) '*entry) 
	    (setq AList (cons (cons (second X) CodeSize*) AList))) 
	       % branch: enter the address of the following instruction
	   ((and (GeneralLDRInstructionP Instr) (LocalLabelp (third X))) 
	    (setq CodeSize* (plus CodeSize* (InstructionLength X))) 
	    (setq AList (cons (cons X CodeSize*) AList)))
	   (t
	    (if (and (flagp (first X) 'ForceAlignment)
		     (not (eq 0 (remainder CodeSize* 8))))
		(setq CodeSize* (plus CodeSize* (difference 8 (remainder CodeSize* 8)))))
	    (setq CodeSize* (plus CodeSize* (InstructionLength X)))))))
  (setq BranchAndLabelAList* (ReversIP AList)) 
  (setq InstructionChanged* BranchAndLabelAList*)
  (return BranchAndLabelAList*) ))


(commentoutcode
 %% 1. Approach: commented out

(de FindFarLoads nil
 (prog (CurrentDisplacement ResultList newcode x y)
  (foreach entry on BranchAndLabelAList* do 
    (cond ((not (LabelP (car (first entry)))) 
      (progn 
	(setq CurrentDisplacement (FindDisplacement (first entry)))
	(cond 
	 ((or (GreaterP CurrentDisplacement (const MaximumPCRelLoadOffset))
	      (Lessp CurrentDisplacement (minus (const MaximumPCRelLoadOffset))))

	  (setq newcode (MakeFarLoad (car entry) ResultList))
%	  (printf "BranchCodeList is %w%n" BranchCodeList*)
	  (cond (newcode
		 %% make sure that the label of th edata itme occurs only once
		 %% by collecting code for the same data item
		 (setq x ResultList)
		 (setq ResultList (cons newcode ResultList))
		 (while x
		   (cond ((equal (second newcode) (second (first x)))
			  %% found, collect instructions
			  (nconc (first x) (cddr newcode))
			  (printf "Appended %p to %p%n" (cddr newcode) (first x))
			  %% pop ResultList
			  (setq ResultList (cdr ResultList))
			  (setq x nil))
			 (t (setq x (cdr x))))
		 )))))))))
  %% inline version of reversip with using cdr of each element
  (while (pairp ResultList)
    (setq x (cdr ResultList))
    (rplaca ResultList (cdar ResultList))
    (setq y (rplacd ResultList y))
    (setq ResultList x))
  (return y))
  )

(de MakeFarLoad (instpair ResultList)
(prog (Instruction Result OppositeBranch n oldopcode olddest oldlabel newlabel found) 
      (setq Instruction (car instpair))
      (setq oldopcode (first Instruction))
      (setq olddest (second Instruction))
      (setq oldlabel (third Instruction))
      %% Check whether a far load for this instruction was already generated
      (setq found (assoc Instruction ResultList))
      (cond ((null found)
	     (setq newlabel (gensym)))
	    (t
	     (setq newlabel (caddr found))))
      (printf "Replacing %w " Instruction)
      (Rplaca Instruction 'BL)
      (Rplacd Instruction (list newlabel))
      (printf " by %w%n " Instruction)
      (cond (found (return nil)))
      (return `(,(list oldopcode olddest oldlabel)
		,oldlabel
		    %% These are the instructions to be inserted immediately before
		    %% the label oldlabel
		.,(list newlabel
			(list oldopcode olddest oldlabel)
			(list 'BX (list 'REG 'LR)))
		))))

)

(de FindFarLoads nil 
 (prog (CurrentDisplacement) 
  (foreach entry on BranchAndLabelAList* do 
    (cond ((not (LabelP (car (first entry)))) 
      (progn 
	(setq CurrentDisplacement (FindDisplacement (first entry))) 
	(cond 
	 ((or (GreaterP CurrentDisplacement (const MaximumPCRelLoadOffset))
	      (Lessp CurrentDisplacement (minus (const MaximumPCRelLoadOffset))))
	  %% PC-relative offset is beyond the 12 bit limit +/-4096
	  (progn (setq InstructionChanged* t) 
	      (IncreaseAllOffsets entry (MakeFarLoad entry)))))))))))

(de MakeFarLoad (AList)
    %% AList if the rest of BranchAndLabelAList*,
    %% starting with the far load to be replaced
  (prog (InstructionList Result n) 
    (setq InstructionList (car (first AList))) 
    (setq n (instructionlength InstructionList))
    (Rplaca InstructionList 'LDR!=) 	% Address load pseudo instruction
    (setq n (difference (instructionlength InstructionList) n))
    (cond ((cdr AList) (Rplacw AList (cdr AList)))
	  (t (Rplacw AList (list (cons '~DummyLabel~ 0))))) 
    (return n))) % increased length of subsequent code



(de FindDisplacement (InstructionOffsetPair) 
    (Abs (Difference (cdr InstructionOffsetPair) 
		    (FindLabelOffset (third (first InstructionOffsetPair))))))

%  FindLabelOffset(Label)
% Purpose: looks up the location of Label in BranchAndLabelAList!*
% Returns: the offset of said Label

(de FindLabelOffset (L) 
(prog (Offset) 
    (return 
     (cond ((EqCar L 'InternalEntry) (FindEntryOffset (second L))) 

	   ((setq Offset (Atsoc (saniere-Sprungziel L) BranchAndLabelAList*)) (cdr Offset))
	   (t (StdError (BldMsg "Unknown label %r" L)))))))


%  FindEntryOffset(ProcedureName);
% Purpose: looks up the location of ProcedureName in BranchAndLabelAList!*
% Returns: the offset of said ProcedureName
%          if an entry point is not known for this procedure it returns a
%          dummy value of -2000

(de FindEntryOffset (L) 
    (cond ((setq L (Atsoc L BranchAndLabelAList*)) (cdr L)) (t -2000)))

(de IncreaseAllOffsets (X N) 
    (foreach Y in X do (Rplacd Y (plus (cdr Y) N))) 
    (setq CodeSize* (plus CodeSize* N)))

% ------------------------------------------------------------
% Procedures to compute instruction lengths
% ------------------------------------------------------------

(de InstructionLength (X)
   (prog (Y) 
       (when (setq Y (get (car x) 'InstructionLengthFunction))
	     (return (apply4safe y (cdr x))))
       (when (setq Y (get (car x) 'INSTRUCTIONLENGTH))
	 (return (if (numberp y) y (apply y (list x)))))
       (return 4)))
%       (stderror (bldmsg "*** Unknown Aarch64 instruction:%w " x))))

(de apply2safe(y x) % ensure that plly has two parameters at least
     (cond ((null x) (apply y (list nil nil)))
	   ((null (cdr x)) (apply y (list (car x) nil)))
	   (t (apply y (list (car x)(cadr x))))))

(de apply3safe(y x) % ensure that plly has three parameters at least
     (cond ((null x) (apply y (list nil nil nil)))
	   ((null (cdr x)) (apply y (list (car x) nil nil)))
	   ((null (cddr x)) (apply y (list (car x) (cadr x) nil)))
	   (t (apply y (list (car x)(cadr x)(caddr x))))))

(de apply4safe(y x) % ensure that plly has four parameters at least
     (cond ((null x) (apply y (list nil nil nil nil)))
	   ((null (cdr x)) (apply y (list (car x) nil nil nil)))
	   ((null (cddr x)) (apply y (list (car x) (cadr x) nil nil)))
	   ((null (cdddr x)) (apply y (list (car x) (cadr x) (caddr x) nil)))
	   (t (apply y (list (car x)(cadr x)(caddr x)(cadddr x))))))

(de InlineConstantLength (X) 
% Purpose: returns the Size_Of_Unit_In_Bytes * Number_Of_Such_Units
%   X has the form:
%          (Unit  value_1  value_2 value_3 .... )
    (Times2 (cond ((equal (first X) 'fullword) 8) (t 2)) 
	    (length (rest X))))

(de ByteConstantLength (X) 
    (Times2 (Quotient (Plus2 (length (rest X)) 1) 2) 2))

(de LapStringLength (X)                 % must fall on word boundary
% Purpose: Calculate the number of bytes occupied by a given string
%  X has the form: (STRING "xxxxxx")
    (Times2 (Quotient (Plus2 (Size (second X)) 9) 8) 8))

(DefList '((fullword InlineConstantLength) 
	  (halfword InlineConstantLength) 
	  (byte ByteConstantLength) 
	  (float 8) 
	  (string LapStringLength)) 'InstructionLength)


(put '*entry 'InstructionLength 0)
(put 'comment 'InstructionLength 0)
(put 'samelinecomment 'InstructionLength 0)

% ------------------------------------------------------------
% Depositing Operations
% ------------------------------------------------------------

(de DepositByte (X) 
(progn (putbyte (wPlus2 CodeBase* CurrentOffset*) 0 X) 
    (UpdateBitTable 1 0) 
    (setq CurrentOffset* (plus CurrentOffset* 1))))

(de DepositHalfWord (X) 
(progn (puthalfword (wPlus2 CodeBase* CurrentOffset*) 0 X) 
    (UpdateBitTable 2 0) 
    (setq CurrentOffset* (plus CurrentOffset* 2))))

(de deposit32bitword (x) %% cross
  (put_a_halfword (wplus2 codebase* currentoffset*) x)
  (updatebittable 4 0)
  (setq currentoffset* (plus currentoffset* 4)))

(de DepositWord (x)
  (putword (wplus2 CodeBase* CurrentOffset*) 0 x)
  (updatebittable 8 0)
  (setq CurrentOffset* (plus CurrentOffset* 8)))

(de deposit-relocated-word (offset)
  % Given an OFFSET from CODEBASE*, deposit a word containing the
  % absolute address of that offset.
  (put_a_halfword (wplus2 CodeBase* CurrentOffset*)
	   (iplus2 offset (if *writingfaslfile 0 CodeBase*)))
  (updatebittable 4 (const reloc_word))
  (setq CurrentOffset* (plus CurrentOffset* 4)))

(de DepositWordExpression (x)
  % Only limited expressions now handled
  (let (y)
%    (printf "Deposit %w at %x -> %x%n" x CurrentOffset* (wplus2 CodeBase* CurrentOffset*))
    (cond
      ((fixp x) (deposit32bitword (int2sys x)))
      ((labelp x) (deposit-relocated-word (LabelOffset x)))
      ((equal (first x) 'internalentry) 
       (let ((offset (get (second x) 'internalentryoffset)))
	 (if offset
	     (deposit-relocated-word offset)
	     (progn
	       (setq ForwardInternalReferences*
		     (cons (cons CurrentOffset* (second x))
			   ForwardInternalReferences*))
	       (deposit-relocated-word 0)))))
      ((equal (first x) 'idloc) (depositwordidnumber (second x)))
      ((equal (first x) 'entry) (DepositEntry x))
      (t (stderror (bldmsg "Expression too complicated %r" x))))
%    (printf "Deposited at %x: %x >%x< %x%n"
%	    (wplus2 (wplus2 CodeBase* CurrentOffset*) -4)
%	    (getword32 (wplus2 (wplus2 CodeBase* CurrentOffset*) -8) 0)
%	    (getword32 (wplus2 (wplus2 CodeBase* CurrentOffset*) -4) 0)
%	    (getword32 (wplus2 CodeBase* CurrentOffset*) 0)
%	    )
    ))

(de DepositQuadWordExpression (x)
  % Only limited expressions now handled
  (let (y)
    (cond
      ((fixp x) (depositword (int2sys x)))
      ((labelp x) (deposit-relocated-word (LabelOffset x)))
      ((equal (first x) 'internalentry) 
       (let ((offset (get (second x) 'internalentryoffset)))
	 (if offset
	     (deposit-relocated-word offset)
	     (progn
	       (setq ForwardInternalReferences*
		     (cons (cons CurrentOffset* (second x))
			   ForwardInternalReferences*))
	       (deposit-relocated-word 0)))))
      ((and (eq (car x) 'mkitem)
	    (eq (cadr x) id-tag)
	    (eqcar (setq y (caddr x)) 'idloc)
	    (wlessp (id2int (cadr y)) 257))
	(depositword (cadr y)))
      ((equal (first x) 'idloc) (depositquadwordidnumber (second x)))
      ((equal (first x) 'mkitem) (DepositItem (second x) (third x)))
      ((equal (first x) 'entry) (DepositEntry x))
      ((memq (first x) '(fluid global $fluid $global)) (DepositValueCellLocation (second x)))
      ((setq y (wconstevaluable x)) (DepositWord (int2sys y)))
      (t (stderror (bldmsg "Expression too complicated %r" x))))
    ))

(de depositwordidnumber (x) 
  (cond
    ((or (not *writingfaslfile) (leq (idinf x) 256)) 
     (deposit32bitword (idinf X)))
    (t
      (put_a_halfword (wplus2 CodeBase* CurrentOffset*)
	       (makerelocword (const reloc_id_number) (findidnumber x))) 
      (setq CurrentOffset* (plus CurrentOffset* 4)) 
      (updatebittable 4 (const reloc_word)))))

(de depositquadwordidnumber (x) 
  (cond
    ((or (not *writingfaslfile) (leq (idinf x) 256)) 
     (depositword (idinf X)))
    (t
      (putword (wplus2 CodeBase* CurrentOffset*) 0
	       (MakeRelocInf (const RELOC_ID_NUMBER) (findidnumber x))) 
      (setq CurrentOffset* (plus CurrentOffset* 8)) 
      (updatebittable 8 (const RELOC_INF)))))

(de DepositHalfWordExpression (X) 
(prog (Y) 
    (return (cond ((FixP X) (DepositHalfWord X)) 
    ((LabelP X) 
    (progn (puthalfword (wPlus2 CodeBase* CurrentOffset*) 0 
		    (IPlus2 (LabelOffset X) 
			   (cond (*WritingFaslFile 0) (t CodeBase*)))) 
	(UpdateBitTable 2 (const RELOC_HALFWORD)) 
	(setq CurrentOffset* (plus CurrentOffset* 2)))) 
    
	    ((and (equal (first X) 'Difference) (LabelP (second X)) 
	    (LabelP (third X))) 
	   (DepositHalfWord (Difference (LabelOffset (second X)) 
					   (LabelOffset (third X))))) 
    ((equal (first X) 'IDLoc) 
	   (DepositHalfWordIDNumber (second X))) 
    ((setq Y (WConstEvaluable X)) 
	   (DepositHalfWord Y)) (t 
    (StdError (BldMsg "Halfword expression too complicated %r" X)))))))


(de DepositItem (TagPart InfPart) 
    (cond ((not *WritingFaslFile) 
	   (DepositWord 
	       (MkItem TagPart 
		       (cond ((LabelP InfPart) 
			      (wPlus2 CodeBase* (LabelOffset InfPart))) 
			     ((equal (first InfPart) 'IDLoc) 
			      (IDInf (second InfPart))) 
			     (t 
				(StdError 
				    (BldMsg "Unknown inf in MkItem %r"
					    InfPart)))))))
	  (t 
	     (progn (cond 
		     ((LabelP InfPart)      % RELOC_CODE_OFFSET = 0
		      (putword (wPlus2 CodeBase* CurrentOffset*) 0 
		       (MkItem TagPart (LabelOffset InfPart)))) 
		     ((equal (first InfPart) 'IDLoc) 
		      (putword (wPlus2 CodeBase* CurrentOffset*) 0 
		       (MkItem TagPart 
			(MakeRelocInf (const RELOC_ID_NUMBER) 
			  (FindIDNumber (second InfPart))))))
		     (t 
		      (StdError (BldMsg "Unknown inf in MkItem %r"
				 InfPart))))
	      (setq CurrentOffset* (plus CurrentOffset* 8))
	      (UpdateBitTable 8 (const RELOC_INF))))))

(de DepositHalfWordIDNumber (X) 
    (cond ((or (not *WritingFaslFile) (LEQ (IDInf X) 128)) 
	(DepositHalfWord (IDInf X))) (t 
    
    (progn (puthalfword (wplus2 CodeBase* CurrentOffset*) 0 
		    (makerelochalfword (const reloc_id_number) (findidnumber x))) 
	(setq CurrentOffset* (plus CurrentOffset* 2)) 
	(updatebittable 2 (const reloc_halfword))))))

% ------------------------------------------------------------
% this procedure was "inserted" to eliminate the problem with the compiler
% not generating the code for:
% function lambda y;remprop(y, 'internalentryoffset);
% who knows why it didn't generate anything reasonable - it generated nil.
(de remove-ieo-property (y) 
  (remprop y 'internalentryoffset))
% ------------------------------------------------------------

(de systemfaslfixup ()
  (prog (x wrd)
%     (printf "%nForwardInternalReferences: %w%n" ForwardInternalReferences*)
     % THIS VERSION ASSUMES 32 bit RELATIVE ADDESSES, HM.
     (setq x (remainder CurrentOffset* 16))
     (while (greaterp x 0) (DepositByte 0) (setq x (sub1 x)))
     (while ForwardInternalReferences*
       (setq x (get (cdr (first ForwardInternalReferences*)) 
		    'internalentryoffset))
%       (printf "Fix Forward ref at %d to %d%n" (car (first ForwardInternalReferences*)) x)
       (when (null x) 
	      (errorprintf "***** %r not defined in this module, call incorrect" 
			   (cdr (first ForwardInternalReferences*))))
       % calculate the offset
       (setq x              % offset of PC in branch instruction
	     (difference x (car (first ForwardInternalReferences*))))
%       (printf "Offset is %d%n" x)
       (setq x (wshift x -2))		% offset is in words, not bytes
       % insert the fixup into the lower 26 bits, upper 6 bits are opcode
       (setq wrd (getword32 (iplus2 CodeBase* (car (first ForwardInternalReferences*))) 0))
%       (printf "instruction is %x --> %x%n"
%	       (wand wrd 16#ffffffff)
%	       (wor (wand wrd 16#fc000000) (wand x 16#03ffffff)))
       (setq wrd (wor (wand wrd 16#fc000000) (wand x 16#03ffffff)))
       (put_a_halfword (iplus2 CodeBase* (car (first ForwardInternalReferences*))) wrd)
%       (printf "New instruction is %x%n" (wand (wgetv (iplus2 CodeBase* (car (first ForwardInternalReferences*))) 0) 16#ffffffff))
       (setq ForwardInternalReferences* (cdr ForwardInternalReferences*)))
	      % Now remove the InternalEntry offsets from everyone
   (mapobl 'remove-ieo-property)))

%-----------------------------------------------------------------
%
% Optimize:
%   1.  (prog (a b c d e) :
%    (mov (quote nil) (reg t1)) (mov (reg t1)(frame 1))
%    (mov (quote nil) (reg t1)  (mov (reg t1)(frame 2))
%        ......
%
%   2. (setq a b)(xxx   ... b )
%    (mov (reg 1) (frame 1)) (mov (frame 1) (reg 2))
 
(de LapoptFrame(u)
    (prog (rcode instr op nextinstr src dest x)
       (while u
	(setq instr (pop u))
	(when (and (pairp instr) u)
		(setq op (car instr))
		(setq nextinstr (car u))
		    % pattern:
		    %    (str (reg n) (frame m))
		    %    (ldr (reg k) (frame m))
		(when (and (eq op 'STR) 
			   (regp (setq src (cadr instr)))
			   (setq dest (caddr instr))
			   (eqcar nextinstr 'LDR)
			   (equal (caddr nextinstr) dest)
			   (regp (setq x (cadr nextinstr))))
		      (pop u)
		      (push (list 'mov x src) u))
		    % pattern:
		    %    (sub (reg st) (reg st) 4)
		    %    (str (reg k) (indirect (reg st))) a.k.a. (frame 1)) 
		    % replace by (str (reg k) (displacement (reg st) -4 preindexed))
		(when (and (eq op 'SUB)
			   (equal (cadr instr) '(reg st))
			   (equal (caddr instr) '(reg st))
			   (equal (cadddr instr) '4)
			   (null (cddddr instr))
			   (eqcar nextinstr 'STR)
			   (regp (cadr nextinstr))
			   (equal (caddr nextinstr) '(indirect (reg st))))
		      (pop u)
		      (setq instr `(STR ,(cadr nextinstr) (displacement (reg st) -4 preindexed))))
		    % pattern:
		    %    (sub (reg st) (reg st) <multiple-of-4>)
		    %    (str (reg k) (displacement (reg st) n)) a.k.a. (frame ..)) 
                    % if n = <multiple-of-4>-4
		    % replace by 
                    %    (str (reg k) (displacement (reg st) -4 preindexed))
                    %    (sub (reg st) (reg st) <multiple-of-4>-4)
		(when (and (eq op 'SUB)
			   (equal (cadr instr) '(reg st))
			   (equal (caddr instr) '(reg st))
			   (fixp (cadddr instr))
			   (equal (cadddr instr) (wshift (wshift (cadddr instr) -2) 2)) % multiple of 4
			   (null (cddddr instr))
			   (eqcar nextinstr 'STR)
			   (regp (setq src (cadr nextinstr)))
			   (pairp (setq dest (caddr nextinstr)))
			   (eq (car dest) 'displacement)
			   (equal (cadr dest) '(reg st))
			   (fixp (setq x (caddr dest)))
			   (equal (difference (cadddr instr) x) 4))
%		      (print (list 'lapopt-before (car u) instr))
		      (pop u)
		      (push `(SUB (reg st) (reg st) ,x) u)
		      (setq instr `(STR ,src (displacement (reg st) -4 preindexed)))
%		      (print (list 'lapopt-after (car u) instr))
		      )
		    % pattern: 
		    %      (push (quote nil) )   
		    %      (push (quote nil) ) ... 
		(when (and
			(eq op 'push) 
			(immediatep (setq src (cadr instr))) 
			(or (and 
			       (eqcar nextinstr 'mov) 
			       (equal (cadr nextinstr) src))
			    (and
			       (eqcar nextinstr 'push)
			       (equal (cadr nextinstr) src)))) 
		      (setq u (LapoptFrame1 src (push instr u))) 
		      (setq instr (list 'mov src '(reg t1))))

	)
	(push instr rcode))
       (return (reversip rcode))))
 
(de LapoptFrame1 (src u)
     % here subsequent instructions are modified for source T1
   (cond ((or (null u) (atom (car u))) u)
	 ((and (eq (caar u) 'PUSH) (equal (cadr (car u)) src))
		(cons '(PUSH (reg t1)) (LapoptFrame1 src (cdr u))))
	 ((not (and (eq(caar u) 'MOV) % nor more such instr.
		    (equal (cadar u) src)))
	  u)
	 ((equal (caddr (car u)) '(reg t1))
		(LapoptFrame1 src (cdr u)))
	 (t  (cons
		(list 'mov '(reg t1) (caddr (car u)))
		(LapoptFrame1 src (cdr u))))))

(fluid '(!*optimize-aarch64))

(setq *optimize-aarch64 t)

(de LapoptPeep(code)
   (when *optimize-aarch64 (setq code (LapoptPeepAarch64 code)))
   code)


%% Reminders:
%% 1) optimize (LDR (reg n) (addr)) followed by (LDR/STR (reg m) (addr))
%%    [tostringwritechar]
%%
%%(*wplus2 (memory ($fluid tokenbuffer) (wconst 0)) (wconst 1))
%%        (ldr (reg t2) (idloc tokenbuffer))
%%        (ldr (reg t1) (displacement (reg symval) (regshifted t2 lsl 2)))
%%        (ldr (reg t2) (idloc tokenbuffer))
%%        (ldr (reg t2) (displacement (reg symval) (regshifted t2 lsl 2)))
%%        (ldr (reg t3) (indirect (reg t2)))
%%        (add (reg t3) (reg t3) 1)
%%        (str (reg t3) (indirect (reg t1)))
%%
%%(*move (memory ($fluid tokenbuffer) (wconst 0)) (reg 2))
%%        (ldr (reg t2) (idloc tokenbuffer))
%%        (ldr (reg t1) (displacement (reg symval) (regshifted t2 lsl 2)))
%%        (ldr (reg 2) (indirect (reg t1)))
%%
%% 2) optimize (mov (reg n) (reg m)) (lsl (reg n) 3)
%%         --> (mov (reg n) (regshifted m LSL 3)) [from wgetv]
%% 3) optimize (add (reg n) (reg n) (reg m)) (ldr (reg k) (indirect (reg n))
%%         --> (ldr (reg k) (indexed (reg n) (reg m))) [from wgetv]

(de LapoptPeepAarch64 (code)
% peephole optimizer for aarch6 code
% interchanging instructions for dependencies.
 (let (rcode i1 i2 i3 r rb)
  (while code
   (setq i1 (pop code))
   (when code
     (setq i2 (car code) i3 (if (cdr code) (cadr code)))
    (cond
      % case
      %   (add/sub (reg n) ... ))
      %   (cmp (reg n) 0)
      % replace add/sub by adds/subs and remove cmp instruction
     ((and (eqcar i2 'cmp) (eq (caddr i2) 0)
	   (pairp i1)
	   (memq (car i1) '(add sub))
	   (equal (cadr i1) (cadr i2))
	   )
      (pop code)		% remove cmp instruction
      (setq i1 (sublis '((adc . adcs)
      	                 (add . adds)
			 (sub . subs)
			 (sbc . sbcs)
			 (neg . negs)
			 (ngc . ngcs)
			 (and . ands)
			 (bic . bics))
		       i1)))

      % case
      %   (cmp (reg n) 0)
      %   (B.eq / B.ne label)
      % replace by CBZ /CBNZ instruction
     ((and (pairp i2) (memq (car i2) '(B!.eq B!.ne))
	   (eqcar i1 'cmp) (eq (caddr i1) 0)
	   )
      (pop code)		% remove branch instruction
      (setq i1 (list (car (sublis '((B!.eq . cbz)
				    (B!.ne . cbnz))
				  i2))
		     (cadr i1)		% register in cmp instr
		     (cadr i2)		% label in branch instr
		     )))

      % case
      %   something
      %   (mov (reg x) ...)
      %   (yyy ... (displacement (reg x))
      % move (mov (reg x) ...)  one step up if independent
     ((and
       (pairp i1)
       (eqcar i2 'mov)
       (eqcar (setq r (caddr i2)) 'reg)
       (equal r (&indirectbase i3))
       (not (&jumpcontrol i1))
	    % test independence (target i2) and i1
       (not (&smember r i1))
	    % test independence (source i2) and (target i1)
       (setq rb (&regbase (cadr i2)))
       (or (and (eqcar i1 'mov) (not (&smember rb (caddr i1))) )
	   (not (&smember rb i1))
       )
      )

      (pop code)
      (push i1 code)
      (setq i1 i2)
     )) % cond
    )% when
    (push i1 rcode)
   )% while
   (reversip rcode)
)) % let,de

(de &smember(a l)
  (cond ((equal a l) t)
	((atom l) nil)
	((&smember a (car l)) t)
	(t (&smember a (cdr l))) ))

(de &indirectbase(u)
  (cond ((atom u) nil)
	((atom (cdr u)) nil)
	((eq (car u) 'displacement) (cadr u))
	((eq (car u) 'indirect) (cadr u))
	(t (or (&indirectbase (car u))(&indirectbase (cdr u)))) ))

(de &regbase(u)
  % u is an operand of *MOVE. Extract the source base. 
     (cond((or (atom u)(eq (car u) 'quote)) t) 
	  ((eq (car u) 'reg) u)
	  ((or (eq (car u) 'indirect) (eq(car u)'displacement))
	   (cadr u))
	  (t t)))

(de &jumpcontrol(u)
    (or (atom u)
	 (LocalLabelp u)
	(GeneralBranchInstructionP (setq u (car u)))
	(eq u 'call)
	(eq u 'ret)
	(eq u '*entry)  
   ))

(de lapoptprint(l)
   (terpri)
   (prin2t " armv6 tauschen:")
   (mapc l 'prin2t))

%---------------------------------------------------------------------
%  cmacro optimizer
%---------------------------------------------------------------------

(de lapopt1 (u)
    (prog()
	(when (not *lapopt) (return u))
	(setq u (lapopt-move-special-cases u))
	(return u)))

%  Move bodies of if-then-elseif ... sequences  such that at runtime as few
%  jumps as possible are taken.

(fluid '(&cond-cm&))

(setq &cond-cm& 
 '((*jumpeq      . *jumpnoteq)       (*jumpnoteq      . *jumpeq)
   (*jumpwgeq    . *jumpwlessp)      (*jumpwlessp     . *jumpwgeq)
   (*jumpwleq    . *jumpwgreaterp)   (*jumpwgreaterp  . *jumpwleq)
   (*jumptype    . *jumpnottype)     (*jumpnottype    . *jumptype)
   (*jumpintype  . *jumpnotintype)   (*jumpnotintype  . *jumpintype)
  % no inverse jumps for
   (*jumpon)
   
))

(de lapopt-move-special-cases(code)
  (let (rcode bcode inst u w lbl lab)
   (while (not (lapopt-bottom code))
    (setq inst (pop code))
     (when 
      (and
       (pairp inst)
       (setq u (atsoc (car inst) &cond-cm&))
       (setq u (cdr u))
       (setq lbl (cadr inst))
       (or (memq lbl code)(member (setq lbl (list '*lbl lbl)) code))
       (setq w (lapopt-move-special-cases1 code lbl))
      )
      (setq lab (list 'label (gensym)))
      (setq bcode (nconc bcode (cons (list '*lbl lab) (car w))))
      (push (cons u (cons lab (cddr inst))) rcode)
      (setq inst nil)
      (setq code (cdr w))
     )
     (when inst (push inst rcode))
    )
  (setq code (nconc (reversip rcode) (nconc bcode code)))
  (when *trlapopt 
	 (prin2t "=== move special cases:")
	 (MAPCAR code 'PRINT))
  code    
)) 

(de lapopt-bottom(u)
 (or (null u) 
     (eqcar (car u) 'fullword)))

(de lapopt-move-special-cases1 (code lbl)
  % Find basic block until lbl which ends by an unconditional jump.
  % Return nil or pair of bblock and rest of code.
  (let (rcode fcode inst op)
   (while code
     (setq inst (pop code))
     (push inst rcode)
     (cond ((or (atom inst) (equal inst lbl)) (setq code nil))
	   ((and (memq (setq op (car inst)) 
		      '(*jump *linke *exit))
		 (cdr code)
		 (equal (car code) lbl)
	    )
	    (setq fcode code) (setq code nil))
	   ((or (eq op '*lbl) (atsoc op &cond-cm&))
	    (setq code nil)
	   )
   ))
   (when fcode (cons (reversip rcode) fcode))
))

(dskin "aarch64-inst.dat")

A psl/dist/comp/macaarch64/macaarch64-spec.sl => psl/dist/comp/macaarch64/macaarch64-spec.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/aarch64-spec.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/make-instructions => psl/dist/comp/macaarch64/make-instructions +1 -0
@@ 0,0 1,1 @@
../aarch64/make-instructions
\ No newline at end of file

A psl/dist/comp/macaarch64/muls.sl => psl/dist/comp/macaarch64/muls.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/muls.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/nbittab.sl => psl/dist/comp/macaarch64/nbittab.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/nbittab.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/sys-consts.sl => psl/dist/comp/macaarch64/sys-consts.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/sys-consts.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/sys-dm.sl => psl/dist/comp/macaarch64/sys-dm.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/sys-dm.sl
\ No newline at end of file

A psl/dist/comp/macaarch64/tags.sl => psl/dist/comp/macaarch64/tags.sl +1 -0
@@ 0,0 1,1 @@
../aarch64/tags.sl
\ No newline at end of file

M psl/dist/kernel/aarch64/bpsl => psl/dist/kernel/aarch64/bpsl +0 -0
M psl/dist/kernel/aarch64/dmain.s => psl/dist/kernel/aarch64/dmain.s +171 -171
@@ 1108,6 1108,36 @@ symprp:
  .space 2395936
 .globl symnam
symnam:
 .globl l0479
 .quad [[4<<56]+l0479]
 .globl l0480
 .quad [[4<<56]+l0480]
 .globl l0481
 .quad [[4<<56]+l0481]
 .globl l0482
 .quad [[4<<56]+l0482]
 .globl l0483
 .quad [[4<<56]+l0483]
 .globl l0484
 .quad [[4<<56]+l0484]
 .globl l0485
 .quad [[4<<56]+l0485]
 .globl l0486
 .quad [[4<<56]+l0486]
 .globl l0487
 .quad [[4<<56]+l0487]
 .globl l0488
 .quad [[4<<56]+l0488]
 .globl l0489
 .quad [[4<<56]+l0489]
 .globl l0490
 .quad [[4<<56]+l0490]
 .globl l0491
 .quad [[4<<56]+l0491]
 .globl l0492
 .quad [[4<<56]+l0492]
 .globl l0493
 .quad [[4<<56]+l0493]
 .globl l0494
 .quad [[4<<56]+l0494]
 .globl l0495


@@ 2096,36 2126,6 @@ symnam:
 .quad [[4<<56]+l0986]
 .globl l0987
 .quad [[4<<56]+l0987]
 .globl l0988
 .quad [[4<<56]+l0988]
 .globl l0989
 .quad [[4<<56]+l0989]
 .globl l0990
 .quad [[4<<56]+l0990]
 .globl l0991
 .quad [[4<<56]+l0991]
 .globl l0992
 .quad [[4<<56]+l0992]
 .globl l0993
 .quad [[4<<56]+l0993]
 .globl l0994
 .quad [[4<<56]+l0994]
 .globl l0995
 .quad [[4<<56]+l0995]
 .globl l0996
 .quad [[4<<56]+l0996]
 .globl l0997
 .quad [[4<<56]+l0997]
 .globl l0998
 .quad [[4<<56]+l0998]
 .globl l0999
 .quad [[4<<56]+l0999]
 .globl l1000
 .quad [[4<<56]+l1000]
 .globl l1001
 .quad [[4<<56]+l1001]
 .globl l1002
 .quad [[4<<56]+l1002]
  .space 2395936
 .globl symfnc
symfnc:


@@ 2436,22 2436,22 @@ symfnc:
 .quad l0041
 .quad undefinedfunction
 .quad undefinedfunction
 .globl l0385
 .quad l0385
 .globl l0370
 .quad l0370
 .quad undefinedfunction
 .quad undefinedfunction
 .quad undefinedfunction
 .quad undefinedfunction
 .globl l0071
 .quad l0071
 .globl l0083
 .quad l0083
 .globl l0081
 .quad l0081
 .globl l0062
 .quad l0062
 .globl l0386
 .quad l0386
 .globl l0440
 .quad l0440
 .globl l0371
 .quad l0371
 .globl l0425
 .quad l0425
 .globl _psl_main
 .quad _psl_main
 .globl reduceup


@@ 2464,124 2464,124 @@ symfnc:
 .quad undefinedfunction
 .quad undefinedfunction
 .quad undefinedfunction
 .globl l0433
 .quad l0433
 .globl l0108
 .quad l0108
 .globl l0418
 .quad l0418
 .globl l0104
 .quad l0104
 .globl initcode
 .quad initcode
 .globl l0085
 .quad l0085
 .globl l0089
 .quad l0089
 .globl l0083
 .quad l0083
 .globl l0087
 .quad l0087
 .globl faslin
 .quad faslin
 .quad undefinedfunction
 .globl l0431
 .quad l0431
 .globl l0432
 .quad l0432
 .globl l0087
 .quad l0087
 .globl l0430
 .quad l0430
 .globl l0435
 .quad l0435
 .globl l0374
 .quad l0374
 .globl l0416
 .quad l0416
 .globl l0417
 .quad l0417
 .globl l0085
 .quad l0085
 .globl l0415
 .quad l0415
 .globl l0420
 .quad l0420
 .globl l0359
 .quad l0359
 .globl binaryopenread
 .quad binaryopenread
 .globl l0451
 .quad l0451
 .globl l0436
 .quad l0436
 .globl binaryread
 .quad binaryread
 .globl l0443
 .quad l0443
 .globl l0428
 .quad l0428
 .globl binaryreadblock
 .quad binaryreadblock
 .globl l0442
 .quad l0442
 .globl l0427
 .quad l0427
 .globl binaryclose
 .quad binaryclose
 .quad undefinedfunction
 .quad undefinedfunction
 .globl l0154
 .quad l0154
 .globl l0148
 .quad l0148
 .quad undefinedfunction
 .globl l0294
 .quad l0294
 .globl l0282
 .quad l0282
 .globl intern
 .quad intern
 .globl subseq
 .quad subseq
 .globl l0118
 .quad l0118
 .globl l0137
 .quad l0137
 .globl l0114
 .quad l0114
 .globl l0132
 .quad l0132
 .globl gtid
 .quad gtid
 .globl gtconststr
 .quad gtconststr
 .globl copystringtofrom
 .quad copystringtofrom
 .globl l0168
 .quad l0168
 .globl l0172
 .quad l0172
 .globl l0299
 .quad l0299
 .globl l0162
 .quad l0162
 .globl l0166
 .quad l0166
 .globl l0287
 .quad l0287
 .quad undefinedfunction
 .quad undefinedfunction
 .globl plantunbound
 .quad plantunbound
 .globl l0249
 .quad l0249
 .globl l0240
 .quad l0240
 .globl l0242
 .quad l0242
 .globl l0234
 .quad l0234
 .globl gtbps
 .quad gtbps
 .globl gtwrds
 .quad gtwrds
 .globl l0209
 .quad l0209
 .globl l0198
 .quad l0198
 .globl l0388
 .quad l0388
 .quad undefinedfunction
 .globl l0356
 .quad l0356
 .globl l0203
 .quad l0203
 .globl l0192
 .quad l0192
 .globl l0373
 .quad l0373
 .quad undefinedfunction
 .globl l0343
 .quad l0343
 .globl delbps
 .quad delbps
 .globl bittable
 .quad bittable
 .globl l0217
 .quad l0217
 .globl l0219
 .quad l0219
 .globl l0221
 .quad l0221
 .globl l0224
 .quad l0224
 .globl l0234
 .quad l0234
 .globl l0211
 .quad l0211
 .globl l0213
 .quad l0213
 .globl l0215
 .quad l0215
 .globl l0218
 .quad l0218
 .globl l0228
 .quad l0228
 .globl putd
 .quad putd
 .globl putentry
 .quad putentry
 .globl l0267
 .quad l0267
 .globl l0258
 .quad l0258
 .quad undefinedfunction
 .quad undefinedfunction
 .globl stderror
 .quad stderror
 .quad undefinedfunction
 .globl l0272
 .quad l0272
 .globl l0263
 .quad l0263
 .globl gtheap
 .quad gtheap
 .globl l0277
 .quad l0277
 .globl l0267
 .quad l0267
 .quad undefinedfunction
 .quad undefinedfunction
 .globl cons


@@ 2590,41 2590,65 @@ symfnc:
 .quad interrogate
 .globl modify
 .quad modify
 .globl l0313
 .quad l0313
 .globl l0301
 .quad l0301
 .globl put
 .quad put
 .globl l0324
 .quad l0324
 .globl l0312
 .quad l0312
 .globl atsoc
 .quad atsoc
 .quad undefinedfunction
 .globl l0322
 .quad l0322
 .globl l0333
 .quad l0333
 .globl l0310
 .quad l0310
 .globl l0320
 .quad l0320
 .globl plantcodepointer
 .quad plantcodepointer
 .quad undefinedfunction
 .quad undefinedfunction
 .globl l0348
 .quad l0348
 .globl l0335
 .quad l0335
 .globl fluid
 .quad fluid
 .quad undefinedfunction
 .globl l0353
 .quad l0353
 .globl l0340
 .quad l0340
 .quad undefinedfunction
 .globl plantlambdalink
 .quad plantlambdalink
 .globl l0366
 .quad l0366
 .globl l0352
 .quad l0352
 .globl undefinedfunction
 .quad undefinedfunction
 .quad undefinedfunction
 .quad undefinedfunction
 .globl compiledcallinginterpreted
 .quad compiledcallinginterpreted
 .globl l0360
 .quad l0360
 .globl l0361
 .quad l0361
 .globl l0362
 .quad l0362
 .globl l0363
 .quad l0363
 .globl l0364
 .quad l0364
 .globl l0365
 .quad l0365
 .globl l0366
 .quad l0366
 .globl l0367
 .quad l0367
 .globl l0368
 .quad l0368
 .globl l0369
 .quad l0369
 .globl l0372
 .quad l0372
 .globl l0374
 .quad l0374
 .globl l0375
 .quad l0375
 .globl l0376


@@ 2645,8 2669,14 @@ symfnc:
 .quad l0383
 .globl l0384
 .quad l0384
 .globl l0385
 .quad l0385
 .globl l0386
 .quad l0386
 .globl l0387
 .quad l0387
 .globl l0388
 .quad l0388
 .globl l0389
 .quad l0389
 .globl l0390


@@ 2695,22 2725,14 @@ symfnc:
 .quad l0411
 .globl l0412
 .quad l0412
 .globl sigrelse
 .quad sigrelse
 .globl l0413
 .quad l0413
 .globl l0414
 .quad l0414
 .globl l0415
 .quad l0415
 .globl l0416
 .quad l0416
 .globl l0417
 .quad l0417
 .globl l0418
 .quad l0418
 .globl l0419
 .quad l0419
 .globl l0420
 .quad l0420
 .globl l0421
 .quad l0421
 .globl l0422


@@ 2719,30 2741,36 @@ symfnc:
 .quad l0423
 .globl l0424
 .quad l0424
 .globl l0425
 .quad l0425
 .globl l0426
 .quad l0426
 .globl l0427
 .quad l0427
 .globl sigrelse
 .quad sigrelse
 .globl l0428
 .quad l0428
 .globl l0429
 .quad l0429
 .globl l0430
 .quad l0430
 .globl l0431
 .quad l0431
 .globl l0432
 .quad l0432
 .globl l0433
 .quad l0433
 .globl l0434
 .quad l0434
 .globl l0436
 .quad l0436
 .globl l0435
 .quad l0435
 .globl l0437
 .quad l0437
 .globl l0438
 .quad l0438
 .globl l0439
 .quad l0439
 .globl l0440
 .quad l0440
 .globl l0441
 .quad l0441
 .globl l0442
 .quad l0442
 .globl l0443
 .quad l0443
 .globl l0444
 .quad l0444
 .globl l0445


@@ 2757,6 2785,8 @@ symfnc:
 .quad l0449
 .globl l0450
 .quad l0450
 .globl l0451
 .quad l0451
 .globl l0452
 .quad l0452
 .globl l0453


@@ 2783,36 2813,6 @@ symfnc:
 .quad l0463
 .globl l0464
 .quad l0464
 .globl l0465
 .quad l0465
 .globl l0466
 .quad l0466
 .globl l0467
 .quad l0467
 .globl l0468
 .quad l0468
 .globl l0469
 .quad l0469
 .globl l0470
 .quad l0470
 .globl l0471
 .quad l0471
 .globl l0472
 .quad l0472
 .globl l0473
 .quad l0473
 .globl l0474
 .quad l0474
 .globl l0475
 .quad l0475
 .globl l0476
 .quad l0476
 .globl l0477
 .quad l0477
 .globl l0478
 .quad l0478
 .globl l0479
 .quad l0479
 .quad undefinedfunction
 .globl codeaddressp
 .quad codeaddressp

M psl/dist/kernel/aarch64/main.s => psl/dist/kernel/aarch64/main.s +1720 -1720
@@ 469,19 469,19 @@ l0071:
 ldp X29, X30, [sp], #16
 ret
 nop
l0081:
 .quad 9
 .byte 108,111,97,100,45,112,115,108,46,98
 .byte 0,0,0,0,0,0
l0082:
l0075:
 .quad 21
 .byte 65,98,111,117,116,32,116,111,32,108
 .byte 111,97,100,32,76,79,65,68,45,80,83
 .byte 76,0,0
l0078:
 .quad 9
 .byte 108,111,97,100,45,112,115,108,46,98
 .byte 0,0,0,0,0,0
 .quad 0
// (*entry pre-main expr 0)
 .globl l0083
l0083:
 .globl l0081
l0081:
 stp X29, X30, [sp, #-16]!
 mov X29, sp
// (idloc unixcleario)


@@ 496,7 496,9 @@ l0083:
 ldr X11, l0074
 ldr X10, [X23, X11, lsl #3]
 blr X10
 ldr X0, l0075
 adr X0, l0075
 mov X11, #4
 bfi X0, X11, #56, #8
// (idloc console-print-string)
 ldr X11, l0076
 ldr X10, [X23, X11, lsl #3]


@@ 505,7 507,9 @@ l0083:
 ldr X11, l0077
 ldr X10, [X23, X11, lsl #3]
 blr X10
 ldr X0, l0078
 adr X0, l0078
 mov X11, #4
 bfi X0, X11, #56, #8
// (idloc faslin)
 ldr X11, l0079
 ldr X10, [X23, X11, lsl #3]


@@ 519,14 523,10 @@ l0080:
 .quad 328
l0079:
 .quad 327
l0078:
 .quad [[4<<56]+l0081]
l0077:
 .quad 326
l0076:
 .quad 325
l0075:
 .quad [[4<<56]+l0082]
l0074:
 .quad 324
l0073:


@@ 535,89 535,89 @@ l0072:
 .quad 322
 .quad 1
// (*entry console-print-string expr 1)
 .globl l0085
l0085:
 .globl l0083
l0083:
 stp X29, X30, [sp, #-16]!
 mov X29, sp
 ubfx X0, X0, #0, #56
 add X0, X0, #8
 ldp X29, X30, [sp], #16
// (idloc unixputs)
 ldr X11, l0084
 ldr X11, l0082
 ldr X10, [X23, X11, lsl #3]
 br X10
l0084:
l0082:
 .quad 329
 .quad 1
// (*entry console-print-number expr 1)
 .globl l0087
l0087:
 .globl l0085
l0085:
 stp X29, X30, [sp, #-16]!
 mov X29, sp
 ldp X29, X30, [sp], #16
// (idloc unixputn)
 ldr X11, l0086
 ldr X11, l0084
 ldr X10, [X23, X11, lsl #3]
 br X10
l0086:
l0084:
 .quad 330
 .quad 0
// (*entry console-newline expr 0)
 .globl l0089
l0089:
 .globl l0087
l0087:
 stp X29, X30, [sp, #-16]!
 mov X29, sp
 mov X0, #10
 ldp X29, X30, [sp], #16
// (idloc unixputc)
 ldr X11, l0088
 ldr X11, l0086
 ldr X10, [X23, X11, lsl #3]
 br X10
 nop
l0088:
l0086:
 .quad 332
l0094:
l0088:
 .quad 0
 .byte 114,0,0,0,0,0,0,0
l0090:
 .quad 34
 .byte 67,111,117,108,100,110,39,116,32,111
 .byte 112,101,110,32,98,105,110,97,114,121
 .byte 32,102,105,108,101,32,102,111,114,32
 .byte 105,110,112,117,116,0,0,0,0,0
l0095:
 .quad 0
 .byte 114,0,0,0,0,0,0,0
 .quad 1
// (*entry binaryopenread expr 1)
 .globl binaryopenread
binaryopenread:
 stp X29, X30, [sp, #-16]!
 mov X29, sp
 ldr X1, l0090
 adr X1, l0088
 mov X11, #4
 bfi X1, X11, #56, #8
 ubfx X1, X1, #0, #56
 add X1, X1, #8
 ubfx X0, X0, #0, #56
 add X0, X0, #8
// (idloc unixopen)
 ldr X11, l0091
 ldr X11, l0089
 ldr X10, [X23, X11, lsl #3]
 blr X10
 cbnz X0, l0096
 ldr X0, l0092
 cbnz X0, l0092
 adr X0, l0090
 mov X11, #4
 bfi X0, X11, #56, #8
 ldp X29, X30, [sp], #16
// (idloc kernel-fatal-error)
 ldr X11, l0093
 ldr X11, l0091
 ldr X10, [X23, X11, lsl #3]
 br X10
l0096:
l0092:
 ldp X29, X30, [sp], #16
 ret
l0093:
 .quad 334
l0092:
 .quad [[4<<56]+l0094]
l0091:
 .quad 334
l0089:
 .quad 333
l0090:
 .quad [[4<<56]+l0095]
 .quad 1
// (*entry binaryread expr 1)
 .globl binaryread


@@ 626,10 626,10 @@ binaryread:
 mov X29, sp
 ldp X29, X30, [sp], #16
// (idloc xgetw)
 ldr X11, l0097
 ldr X11, l0093
 ldr X10, [X23, X11, lsl #3]
 br X10
l0097:
l0093:
 .quad 336
 .quad 3
// (*entry binaryreadblock expr 3)


@@ 643,10 643,10 @@ binaryreadblock:
 mov X0, X4
 ldp X29, X30, [sp], #16
// (idloc fread)
 ldr X11, l0098
 ldr X11, l0094
 ldr X10, [X23, X11, lsl #3]
 br X10
l0098:
l0094:
 .quad 338
 .quad 1
// (*entry binaryclose expr 1)


@@ 656,143 656,143 @@ binaryclose:
 mov X29, sp
 ldp X29, X30, [sp], #16
// (idloc fclose)
 ldr X11, l0099
 ldr X11, l0095
 ldr X10, [X23, X11, lsl #3]
 br X10
l0099:
l0095:
 .quad 340
 .quad 0
// (*entry initialize-symbol-table expr 0)
 .globl l0108
l0108:
 .globl l0104
l0104:
 stp X29, X30, [sp, #-32]!
 mov X29, sp
 str X28, [sp, #24]
 str X28, [sp, #16]
 ldr X1, l0100
 ldr X1, l0096
// ($global nextsymbol)
 ldr X11, l0101
 ldr X11, l0097
 ldr X0, [X24, X11, lsl #3]
 mov X3, X0
 mov X2, X1
l0109:
l0105:
 cmp X3, X2
 b.gt l0110
 b.gt l0106
 mov X0, X3
 lsl X0, X0, #3
// ($global symnam)
 ldr X11, l0102
 ldr X11, l0098
 ldr X11, [X24, X11, lsl #3]
 add X0, X0, X11
 mov X1, #1
 add X1, X1, X3
 str X1, [X0]
 add X3, X3, #1
 b l0109
l0110:
 b l0105
l0106:
// ($global symnam)
 ldr X11, l0102
 ldr X11, l0098
 ldr X10, [X24, X11, lsl #3]
 ldr X11, l0103
 ldr X11, l0099
 add X10, X10, X11
 mov X9, #0
 str X9, [X10]
 ldr X1, l0104
 ldr X1, l0100
 mov X0, #0
 str X0, [sp, #16]
 str X1, [sp, #24]
l0111:
l0107:
 ldr X9, [sp, #16]
 ldr X10, [sp, #24]
 cmp X9, X10
 b.gt l0112
 b.gt l0108
 mov X2, #0
 ldr X1, [sp, #16]
// ($fluid hashtable)
 ldr X11, l0105
 ldr X11, l0101
 ldr X0, [X24, X11, lsl #3]
 str W2, [X0, X1, lsl #2]
 ldr X10, [sp, #16]
 add X10, X10, #1
 str X10, [sp, #16]
 b l0111
l0112:
 b l0107
l0108:
// ($global symnam)
 ldr X11, l0102
 ldr X11, l0098
 ldr X11, [X24, X11, lsl #3]
 ldr X0, [X11, #2048]
// (idloc hash-into-table)
 ldr X11, l0106
 ldr X11, l0102
 ldr X10, [X23, X11, lsl #3]
 blr X10
 mov X2, #256
 mov X1, X0
// ($fluid hashtable)
 ldr X11, l0105
 ldr X11, l0101
 ldr X0, [X24, X11, lsl #3]
 str W2, [X0, X1, lsl #2]
 movn X1, #0
// ($global nextsymbol)
 ldr X11, l0101
 ldr X11, l0097
 ldr X11, [X24, X11, lsl #3]
 add X1, X1, X11
 mov X0, #256
 str X0, [sp, #16]
 str X1, [sp, #24]
l0113:
l0109:
 ldr X9, [sp, #16]
 ldr X10, [sp, #24]
 cmp X9, X10
 b.gt l0114
 b.gt l0110
 ldr X0, [sp, #16]
 lsl X0, X0, #3
// ($global symnam)
 ldr X11, l0102
 ldr X11, l0098
 ldr X11, [X24, X11, lsl #3]
 add X0, X0, X11
 ldr X0, [X0]
// (idloc hash-into-table)
 ldr X11, l0106
 ldr X11, l0102
 ldr X10, [X23, X11, lsl #3]
 blr X10
 ldr X2, [sp, #16]
 mov X1, X0
// ($fluid hashtable)
 ldr X11, l0105
 ldr X11, l0101
 ldr X0, [X24, X11, lsl #3]
 str W2, [X0, X1, lsl #2]
 ldr X10, [sp, #16]
 add X10, X10, #1
 str X10, [sp, #16]
 b l0113
l0114:
 b l0109
l0110:
 mov X0, X28
// ($global show-new-ids)
 ldr X11, l0107
 ldr X11, l0103
 str X0, [X24, X11, lsl #3]
 ldp X29, X30, [sp], #32
 ret
 nop
l0107:
l0103:
 .quad 345
l0106:
l0102:
 .quad 344
l0105:
l0101:
 .quad 263
l0104:
l0100:
 .quad 393241
l0103:
l0099:
 .quad 2400000
l0102:
l0098:
 .quad 343
l0101:
l0097:
 .quad 342
l0100:
l0096:
 .quad 300000
 .quad 1
// (*entry faslin-intern expr 1)
 .globl l0118
l0118:
 .globl l0114
l0114:
 stp X29, X30, [sp, #-48]!
 mov X29, sp
 str X28, [sp, #40]


@@ 802,19 802,19 @@ l0118:
 mov X1, X0
 mov X0, #0
// (idloc search-string-for-character)
 ldr X11, l0115
 ldr X11, l0111
 ldr X10, [X23, X11, lsl #3]
 blr X10
 str X0, [sp, #24]
 cmp X0, X28
 b.ne l0119
 b.ne l0115
 ldr X0, [sp, #16]
 ldp X29, X30, [sp], #48
// (idloc intern)
 ldr X11, l0116
 ldr X11, l0112
 ldr X10, [X23, X11, lsl #3]
 br X10
l0119:
l0115:
 ldr X0, [sp, #16]
 ubfx X0, X0, #0, #56
 ldr X0, [X0]


@@ 822,7 822,7 @@ l0119:
 str X0, [sp, #32]
 ldr X11, [sp, #24]
 cmp X0, X11
 b.le l0120
 b.le l0116
 mov X1, #1
 ldr X11, [sp, #24]
 add X1, X1, X11


@@ 830,18 830,18 @@ l0119:
 ubfx X0, X0, #0, #56
 add X0, X0, #8
 ldrsb X0, [X0, X1]
 cbnz X0, l0120
 cbnz X0, l0116
 ldr X10, [sp, #24]
 add X10, X10, #1
 str X10, [sp, #24]
l0120:
l0116:
 ldr X9, [sp, #24]
 ldr X10, [sp, #32]
 cmp X9, X10
 b.lt l0121
 b.lt l0117
 ldr X0, [sp, #16]
 b l0122
l0121:
 b l0118
l0117:
 ldr X2, [sp, #16]
 ubfx X2, X2, #0, #56
 ldr X2, [X2]


@@ 852,20 852,20 @@ l0121:
 add X1, X1, X11
 ldr X0, [sp, #16]
// (idloc subseq)
 ldr X11, l0117
 ldr X11, l0113
 ldr X10, [X23, X11, lsl #3]
 blr X10
l0122:
l0118:
 ldp X29, X30, [sp], #48
// (idloc intern)
 ldr X11, l0116
 ldr X11, l0112
 ldr X10, [X23, X11, lsl #3]
 br X10
l0117:
l0113:
 .quad 348
l0116:
l0112:
 .quad 347
l0115:
l0111:
 .quad 346
 .quad 1
// (*entry intern expr 1)


@@ 875,19 875,19 @@ intern:
 mov X29, sp
 ldp X29, X30, [sp], #16
// (idloc unchecked-string-intern)
 ldr X11, l0123
 ldr X11, l0119
 ldr X10, [X23, X11, lsl #3]
 br X10
l0123:
l0119:
 .quad 350
l0136:
l0125:
 .quad 7
 .byte 78,101,119,32,105,100,58,32,0,0,0,0
 .byte 0,0,0,0
 .quad 1
// (*entry unchecked-string-intern expr 1)
 .globl l0137
l0137:
 .globl l0132
l0132:
 stp X29, X30, [sp, #-64]!
 mov X29, sp
 str X0, [sp, #16]


@@ 903,92 903,94 @@ l0137:
 str X2, [sp, #40]
 str X3, [sp, #48]
 str X4, [sp, #56]
 cbnz X1, l0138
 cbnz X1, l0133
 add X0, X0, #8
 ldrsb X0, [X0, X1]
 and X0, X0, #255
 mov X11, #254
 bfi X0, X11, #56, #8
 b l0139
l0138:
 b l0134
l0133:
 ldr X0, [sp, #16]
// (idloc hash-into-table)
 ldr X11, l0124
 ldr X11, l0120
 ldr X10, [X23, X11, lsl #3]
 blr X10
 mov X1, X0
 str X1, [sp, #40]
// ($fluid hashtable)
 ldr X11, l0125
 ldr X11, l0121
 ldr X0, [X24, X11, lsl #3]
 ldr W0, [X0, X1, lsl #2]
 mov X1, X0
 ldr X11, l0126
 ldr X11, l0122
 cmp X0, X11
 b.lt l0140
 b.lt l0135
 mov X0, X28
 b l0141
l0140:
 ldr X0, l0127
l0141:
 b l0136
l0135:
 ldr X0, l0123
l0136:
 cmp X0, X28
 b.eq l0142
 ldr X0, l0127
 b.eq l0137
 ldr X0, l0123
 cmp X1, #0
 b.gt l0142
 b.gt l0137
 add X0, X0, #140
l0142:
l0137:
 cmp X0, X28
 b.eq l0143
 b.eq l0138
 ldr X1, [sp, #40]
// ($fluid hashtable)
 ldr X11, l0125
 ldr X11, l0121
 ldr X0, [X24, X11, lsl #3]
 ldr W0, [X0, X1, lsl #2]
 mov X11, #254
 bfi X0, X11, #56, #8
 b l0139
l0143:
 b l0134
l0138:
// ($global show-new-ids)
 ldr X11, l0128
 ldr X11, l0124
 ldr X11, [X24, X11, lsl #3]
 cmp X0, X11
 b.eq l0144
 ldr X0, l0129
 b.eq l0139
 adr X0, l0125
 mov X11, #4
 bfi X0, X11, #56, #8
// (idloc console-print-string)
 ldr X11, l0130
 ldr X11, l0126
 ldr X10, [X23, X11, lsl #3]
 blr X10
 ldr X0, [sp, #16]
// (idloc console-print-string)
 ldr X11, l0130
 ldr X11, l0126
 ldr X10, [X23, X11, lsl #3]
 blr X10
// (idloc console-newline)
 ldr X11, l0131
 ldr X11, l0127
 ldr X10, [X23, X11, lsl #3]
 blr X10
l0144:
l0139:
// (idloc gtid)
 ldr X11, l0132
 ldr X11, l0128
 ldr X10, [X23, X11, lsl #3]
 blr X10
 str X0, [sp, #56]
 mov X2, X0
 ldr X1, [sp, #40]
// ($fluid hashtable)
 ldr X11, l0125
 ldr X11, l0121
 ldr X0, [X24, X11, lsl #3]
 str W2, [X0, X1, lsl #2]
 ldr X0, [sp, #32]
// (idloc gtconststr)
 ldr X11, l0133
 ldr X11, l0129
 ldr X10, [X23, X11, lsl #3]
 blr X10
 str X0, [sp, #48]
 ldr X1, [sp, #24]
// (idloc copystringtofrom)
 ldr X11, l0134
 ldr X11, l0130
 ldr X10, [X23, X11, lsl #3]
 blr X10
 ldr X1, [sp, #48]


@@ 997,45 999,43 @@ l0144:
 ldr X0, [sp, #56]
 ldp X29, X30, [sp], #64
// (idloc initialize-new-id)
 ldr X11, l0135
 ldr X11, l0131
 ldr X10, [X23, X11, lsl #3]
 br X10
l0139:
l0134:
 ldp X29, X30, [sp], #64
 ret
l0135:
l0131:
 .quad 354
l0134:
l0130:
 .quad 353
l0133:
l0129:
 .quad 352
l0132:
l0128:
 .quad 351
l0131:
l0127:
 .quad 326
l0130:
l0126:
 .quad 325
l0129:
 .quad [[4<<56]+l0136]
l0128:
l0124:
 .quad 345
l0127:
l0123:
 .quad [[254<<56]+116]
l0126:
l0122:
 .quad 4294967295
l0125:
l0121:
 .quad 263
l0124:
l0120:
 .quad 344
l0153:
l0146:
 .quad 18
 .byte 72,97,115,104,32,116,97,98,108,101
 .byte 32,111,118,101,114,102,108,111,119
 .byte 0,0,0,0,0
 .quad 1
// (*entry hash-into-table expr 1)
 .globl l0154
l0154:
 .globl l0148
l0148:
 stp X29, X30, [sp, #-48]!
 mov X29, sp
 str X28, [sp, #40]


@@ 1043,111 1043,111 @@ l0154:
 str X28, [sp, #24]
 str X0, [sp, #16]
// (idloc hash-function)
 ldr X11, l0145
 ldr X11, l0140
 ldr X10, [X23, X11, lsl #3]
 blr X10
 str X0, [sp, #24]
 str X0, [sp, #32]
 movn X9, #0
 str X9, [sp, #40]
l0155:
l0149:
 ldr X1, [sp, #32]
// ($fluid hashtable)
 ldr X11, l0146
 ldr X11, l0141
 ldr X0, [X24, X11, lsl #3]
 ldr W0, [X0, X1, lsl #2]
 cbnz X0, l0156
 cbnz X0, l0150
 ldr X11, [sp, #40]
 cmn X11, #1
 b.eq l0157
 b.eq l0151
 ldr X0, [sp, #40]
 b l0158
l0157:
 b l0152
l0151:
 ldr X0, [sp, #32]
l0158:
 b l0159
l0156:
l0152:
 b l0153
l0150:
 ldr X1, [sp, #32]
// ($fluid hashtable)
 ldr X11, l0146
 ldr X11, l0141
 ldr X0, [X24, X11, lsl #3]
 ldr W0, [X0, X1, lsl #2]
 ldr X11, l0147
 ldr X11, l0142
 cmp X0, X11
 b.ne l0160
 b.ne l0154
 ldr X11, [sp, #40]
 cmn X11, #1
 b.ne l0161
 b.ne l0155
 ldr X9, [sp, #32]
 str X9, [sp, #40]
 b l0161
l0160:
 b l0155
l0154:
 ldr X1, [sp, #32]
// ($fluid hashtable)
 ldr X11, l0146
 ldr X11, l0141
 ldr X0, [X24, X11, lsl #3]
 ldr W0, [X0, X1, lsl #2]
 ldr X1, [sp, #16]
 lsl X0, X0, #3
// ($global symnam)
 ldr X11, l0148
 ldr X11, l0143
 ldr X11, [X24, X11, lsl #3]
 add X0, X0, X11
 ldr X0, [X0]
// (idloc unchecked-string-equal)
 ldr X11, l0149
 ldr X11, l0144
 ldr X10, [X23, X11, lsl #3]
 blr X10
 cmp X0, X28
 b.eq l0161
 b.eq l0155
 ldr X0, [sp, #32]
 b l0159
l0161:
 b l0153
l0155:
 ldr X9, [sp, #32]
 ldr X10, l0150
 ldr X10, l0145
 cmp X9, X10
 b.ne l0162
 b.ne l0156
 mov X0, #0
 b l0163
l0162:
 b l0157
l0156:
 mov X0, #1
 ldr X11, [sp, #32]
 add X0, X0, X11
l0163:
l0157:
 str X0, [sp, #32]
 ldr X11, [sp, #24]
 cmp X0, X11
 b.ne l0155
 ldr X0, l0151
 b.ne l0149
 adr X0, l0146
 mov X11, #4
 bfi X0, X11, #56, #8
// (idloc kernel-fatal-error)
 ldr X11, l0152