~trn/reduce-algebra

d0317fb8e8074b656c4cad7dfaab9d93c716e2c1 — Jeffrey H. Johnson 5 days ago 5fddd1e + 87d39a1
Merge branch 'svn/trunk'
M packages/support/revision.red => packages/support/revision.red +1 -1
@@ 31,6 31,6 @@

fluid '(revision!*);

revision!* := 6016;
revision!* := 6018;

end;

M psl/dist/comp/aarch64/aarch64-cross.sl => psl/dist/comp/aarch64/aarch64-cross.sl +34 -4
@@ 207,6 207,28 @@
%% 			 (setq nextidnumber* (iadd1 nextidnumber*)) i)))))


%%
%% We have a little problem here with the id nubmers of nil and findidnumber:
%%
%%                             cross compiler            target system
%% id number of nil                 128                      256
%% id number of firstkernel  
%% (int2id 256)                  firstkernel                 nil
%% (id2int nil)                     128                      256
%% (id2int 'firstkernel)            256                      257
%%
%%  When the initial values in the symbol table are written to the assembler file,
%% initsymval1 is called for every symbol. For these two cases we have
%%    (initsymval1 (int2id 256))
%% followed by
%%    (initsymval1 'firstkernel)
%% i.e., twice with the same value
%% To get around this I introduce a global variable **nil-seen** that is nil at
%% the beginning, and set to t as seen as (initsymval1 (int2id 256)) is called.
%%

(global '(**nil-seen**))

(de initsymval1 (x)
  (prog (val)
% now decide what to plant in value cell at compiletime.


@@ 230,18 252,26 @@
                          (setq val (get x 'symbol))
                          val)
% print the initial value.
                       ((setq val (get x 'initialvalue)) 
                       ((setq val (get x 'initialvalue))
                        (compileconstant val))
% print the value of nil.
		       ((eq (id2int x) 256)
% print the value of nil. Make sure that this case applies to nil only, not to
% the symbol firstkernel (which happens to have id number 256 in the cross compiler
% because nil has still id number 128)
		       ((and (eq (id2int x) 256) (not **nil-seen**))
			(setq **nil-seen** t)
			(list 'mkitem (compiler-constant 'id-tag) 256))
% print the value of cross compiler nil
                       ((eq (id2int x) 128)
			(list 'mkitem (compiler-constant 'unbound-tag) 128))
                       ((flagp x 'nilinitialvalue) nilnumber*)
                       ((and (flagp x 'nilinitialvalue) (not (eq x 'firstkernel)))
			nilnumber*)
% print the unbound variable value.
                       (t 
                        (list 'mkitem (compiler-constant 'unbound-tag) 
                         (findidnumber x))))))))

(remprop 'nil-t-diff* 'constant?)
(setq nil-t-diff* 140)
(put 'nil-t-diff* 'constant? t)



M psl/dist/comp/aarch64/aarch64-lap-to-asm.sl => psl/dist/comp/aarch64/aarch64-lap-to-asm.sl +4 -3
@@ 106,6 106,8 @@
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load fasl-decls))		% for extraargumentp

(fluid '(semic* *comp *plap dfprint* charactersperword 
                 addressingunitsperitem addressingunitsperfunctioncell 
                 InputSymFile* OutputSymFile* codeout* dataout* rodataout*


@@ 528,12 530,11 @@

(de asmoutlap (u)
  (prog (locallabels* oldout)
        (setq u (pass1lap u))
%        (setq u (pass1lap (&fillframeholes u)))
        (setq u (pass1lap (&fillframeholes u)))
	(setq u (LapoptFrame u))
	(setq u (LapoptPeep u))
%	(setq u (ReformBranches u))
	(setq u (AlignData u))  
	(setq u (alignData u))  
        % Expand cmacros, quoted expressions                               
        (codeblockheader)
        (setq oldout (wrs codeout*))

M psl/dist/kernel/aarch64/aarch64-cross => psl/dist/kernel/aarch64/aarch64-cross +1 -31
@@ 9,6 9,7 @@ $psys/pslcomp <<EOF
(setq loaddirectories!* (cons "$bl/" loaddirectories!*))
(reload sys-consts)
(setq addressingunitsperitem 8)
(setq maxrealregs 8)
(off usermode)
%%(load psl_case)
(load if-system)


@@ 16,47 17,16 @@ $psys/pslcomp <<EOF
(load aarch64-lap-to-asm)
(on plap pgwd)
(on pcmac)
(print (list "nextidnumber*" nextidnumber*))
(load aarch64-asm)
(load aarch64-cmac)
(load aarch64-comp)
(load aarch64-spec)
(load aarch64-cross)
%(remprop 'wquotient 'opencode)
%(remprop 'wremainder 'opencode)
%(setq nil-t-diff* 140)
%(put 'NEGINTP 	'OPENTST 	'(TSTPAT2 !*JUMPTYPE    31))
%(put 'NOTNEGINTP 'OPENTST 	'(TSTPAT2 !*JUMPNOTTYPE 31))
%(put 'IDP 	'OPENTST 	'(TSTPAT2 !*JUMPTYPE    30))
%(put 'NOTIDP 	'OPENTST 	'(TSTPAT2 !*JUMPNOTTYPE 30))
%(put 'BSTRUCTP 'OPENTST 	'(TSTPAT2 !*JUMPTYPE    22))
%(put 'NOTBSTRUCTP 'OPENTST 	'(TSTPAT2 !*JUMPNOTTYPE 22))
%(put 'NEGINTP 	'OPENFN 	'(TVPAT-tag !*JUMPTYPE    31))
%(put 'NOTNEGINTP 'OPENFN 	'(TVPAT-tag !*JUMPNOTTYPE 31))
%(put 'IDP 	'OPENFN 	'(TVPAT-tag !*JUMPTYPE    30))
%(put 'NOTIDP 	'OPENFN 	'(TVPAT-tag !*JUMPNOTTYPE 30))
%(put 'BSTRUCTP 'OPENFN 		'(TVPAT-tag !*JUMPTYPE    22))
%(put 'NOTBSTRUCTP 'OPENFN 	'(TVPAT-tag !*JUMPNOTTYPE 22))
(print (list 'tags (get 'id-tag 'compiler-constant-value)
                   (get 'bstruct-tag 'compiler-constant-value)
                   (get 'negint-tag 'compiler-constant-value)))
%(put 'id-tag 'compiler-constant? t)
%(put 'bstruct-tag 'compiler-constant? t)
%(put 'negint-tag 'compiler-constant? t)
%(put 'id-tag 'compiler-constant-value 254)
%(put 'bstruct-tag 'compiler-constant-value 246)
%(put 'negint-tag 'compiler-constant-value 255)
(print (list "nextidnumber*" nextidnumber*))

(remd 'foreignlink)
%(copyd 'bitma 'bitmask)
%(de bitmask (x y) (cond ((and (eq x 2) (eq y 30))  1073741823)
%			((and (eq x 2) (eq y 14))  1073676288)
%                        (t (bitma x y))))
%(dm extrareg (u)
%  (list 'displacement '(reg st) (plus2 20
%        (times (difference (cadr u) (plus lastactualreg!& 1))
%               (compiler-constant 'addressingunitsperitem)))))
(dskin "tmp.sl")
EOF


A psl/dist/kernel/aarch64/aarch64-native => psl/dist/kernel/aarch64/aarch64-native +33 -0
@@ 0,0 1,33 @@
# /bin/csh
echo "cross"
bl=`dirname $pl`/aarch64-cross ; export bl
$psys/pslcomp <<EOF
(off redefmsg verboseload)
(load debug)
(load addr2id)

%(setq loaddirectories!* (cons "$bl/" loaddirectories!*))
(reload sys-consts)
(setq addressingunitsperitem 8)
(off usermode)
%%(load psl_case)
(load if-system)
%(load aarch64-lap)
(load aarch64-lap-to-asm)
(on plap pgwd)
(on pcmac)
(load aarch64-asm)
%(load aarch64-cmac)
%(load aarch64-comp)
%(load aarch64-spec)
%(load aarch64-cross)
(setq nil-t-diff* 140)

(remd 'foreignlink)
%(copyd 'bitma 'bitmask)
%(de bitmask (x y) (cond ((and (eq x 2) (eq y 30))  1073741823)
%			((and (eq x 2) (eq y 14))  1073676288)
%                        (t (bitma x y))))
(dskin "tmp.sl")
EOF


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 +1 -1
@@ 289,7 289,7 @@ symval:
 .quad [[253<<56]+254]
 .quad [[253<<56]+255]
 .quad [[254<<56]+256]
 .quad [[254<<56]+256]
 .quad [[253<<56]+257]
 .quad stack
 .quad argumentblock
 .quad tokenbuffer

M psl/dist/kernel/aarch64/main.s => psl/dist/kernel/aarch64/main.s +5 -7
@@ 1732,7 1732,7 @@ l0225:
 mov X11, #65510
 cmp X1, X11
 b.lt l0228
 movn X0, #65515
 movn X0, #65518
 add X0, X0, X1
 lsl X0, X0, #3
// ($fluid argumentblock)


@@ 2566,13 2566,12 @@ l0314:
 ldr X0, [sp, #24]
 str X0, [X21]
 mov X0, #9
 lsl X0, X0, #56
 add X0, X0, X21
 orr X0, X21, X0, lsl #56
 str X1, [X21, #8]
 add X21, X21, #16
 cmp X21, X22
 b.lt l0316
 stp X0, X1, [sp, #16]!
 stp X0, X1, [sp, #-16]!
// (idloc !%reclaim)
 ldr X11, l0311
 ldr X10, [X23, X11, lsl #3]


@@ 2582,13 2581,12 @@ l0316:
 ldr X1, [sp, #40]
 str X0, [X21]
 mov X0, #9
 lsl X0, X0, #56
 add X0, X0, X21
 orr X0, X21, X0, lsl #56
 str X1, [X21, #8]
 add X21, X21, #16
 cmp X21, X22
 b.lt l0317
 stp X0, X1, [sp, #16]!
 stp X0, X1, [sp, #-16]!
// (idloc !%reclaim)
 ldr X11, l0311
 ldr X10, [X23, X11, lsl #3]

M psl/dist/lap/aarch64/aarch64-lap-to-asm.b => psl/dist/lap/aarch64/aarch64-lap-to-asm.b +0 -0