LISTING FOR >dumps>old_dumps>lisp_stuff>work>lcp_cg_ COMPILED BY Multics LISP Compiler, Version 2.8x, February 27, 1980 ON 02/27/80 2136.9 mst Wed IN BEHALF OF Martinson.SysMaint.a ;;;(c) Copyright 1973, Massachusetts Institute of Technology. ;;; All rights reserved. ;; ;; pass 2 of the Multics LISP Compiler. ;; ;; Performs the necessary tasks of code generation required by the ;; LISP compiler to generate code for the Multics LISP environment. ;; ;; David Reed,October 1972. ;; Subsequently maintained by Moon, then by Greenberg. ;; (declare (special bindtag errtag catchtag progtag unwptag ; special markers appearing on framel framel ; list of frames which have been pushed on unmkd stack. arg-height ; height ap has been bumped for argument lists and binding blocks. bump-arg-height ; height we want to bump ap for arg lists, ; which we defer until an arg is actually to be stored... temp-size ; actual length in words of slots on marked stack used for temporaries. locvars ; assoc list of local variables with cnt of last usage in functions bvars ; list of local bound variables. exit ; push-down list of labels for current prog return. vgol ; "push down" list of labels for variable go feature. slotlist ; list of contents of stack temporary slots, ; nil in slot means it is free, t is reserved, ; (var .home) is home of local variable, ; (....) is temporary value, ; (var . idup) is a copy of a variable made before a setq. slot-types ; list, corresponding to slotlist, of types of slots ; in slotlist...if nil, any type storable here, if fixnum, ; type field has been initted to fixnum, same for flonum. loadlist ; list of values computed, but not yet used. gofoo ; magic frob for load-time constants null-var-list ; list of names of variables which have been bound to nil but not yet ; used. This only affects local variables, and is a hack. cnt ; time in compilation. slotx ; pointer at free temporary used by freetemp. useless-code ; switch controlling whether code is put out, turned on by ; unconditional jumps, off by label definition. pc ; actual pc of code generated. codelist ; list of internal code representations, reverse order of generation. AQ ; contains value representation of that which is in AQ. AQ-state ; if non-nil, current value in AQ is a numeric intermediate ; result. If the Q contains the value, AQ-state = 'Q ; if the A contains the value, AQ-state = 'A BB ; contents of pr3, in which cons-results are returned. constant-list ; list of all constants referenced by program, maintained by get-const. constant-size ; space occupied by all constants referenced by program. literal-list ; list of all literal constants referenced by program, maintained by get-const. literal-size ; space occupied by all literal constants referred to in code. literal-start ; offset of literals from where we originally expected them to be...kept by ; pass2 and initialize slot-types, used by pass2. entry-list functions-called ; list of names for functions called within compiled code. fcn-size ; counter used in allocating space for function links. pl1-link-list ; list of links for defpl1 pl1-link-size ; next available address in linkage section array-type ; type of array just referenced. array-links ; list of array links. array-size ; counter used in allocating array-link space. functions-defined ; list of name-entrypoint pairs for functions compiled. static ; The static stuff. effs ; indicates whether compiling for effect or value. prog-for-effs ; indicates whether prog is being compiled for effect or value. labels-to-define ; list of labels to be defined to point to next instruction. carlist ;car-cdr deflist last-tra-target ; pc or gensym target of last tra barfp ; used to detect compiler errors in debug mode. seg-name ; free variable passed from pass 1, contains name of segment. defdat ; free variable again...used to generate putprop. time-option total-time ; on if times are to be printed on console... arrays ; list of arrays defined by calls to array in file. source-map ; list of source pathnames generated by input reader compiler-version ; string of compiler version base ; good old output base... *nopoint ; and format controller...we must force base 10 output sometimes. ) (array* (notype (fcn-table ?) (const-table ?))) (fixnum arg-height bump-arg-height temp-size cnt pc constant-size literal-size fcn-size array-size base) (do i (read) (read) (equal i ''END) (eval i)) ; read up compile time operations. ) ; compile time operations: (sstatus macro /! '(lambda () (list 'quote ((lambda (x) (or (get x '/!) (error "undefined compile time constant " x))) (read)) ))) (sstatus macro /| nil) (defun setm fexpr (l) (do x l (cddr x) (null x) ((lambda (thing) (putprop (car x) thing '/!)) (cond ((bigp (setq thing (cadr x))) (setq thing (boole 7 (lsh 1 35.) (haipart thing -35.)))) (t thing)) ))) (setm ; set opcodes and other manifest constants. szn 234000 lda 235000 ldq 236000 ldaq 237000 sta 755000 stq 756000 staq 757000 fdi 525000 fneg 513000 lde 411000 fad 475000 ufa 435000 fsb 575000 fld 431000 fst 455000 fcmp 515000 cmpa 115000 cmpq 116000 cmpaq 117000 cana 315000 eppbp 352000 eppbb 353400 eppbb-bb* 300000353520 epplb 371400 eppap 350000 tralink 400000713120 ;callsp lp|0,* eaa 635000 eaq 636000 orq 276000 lxl0 720000 eax0 620000 eax5 625000 eax7 627000 neg 531000 negl 533000 ada 075000 adq 076000 sba 175000 sbq 176000 mpy 402000 div 506000 arl 771000 qrl 772000 als 735000 qls 736000 alr 775000 qlr 776000 lrl 773000 llr 777000 lls 737000 lcq 336000 spribp 252000 spribb 253400 sprilp 650000 sprilb 651400 sprpbp 542000 lprpbp 762000 tmi 604000 tnz 601000 tpl 605000 tpnz 605400 tmoz 604400 tra 710000 tspbp 272000 tze 600000 xec 716000 asq 056000 stz 450000 orsq 256000 orsa 255000 ersq 656000 ersa 655000 erq 676000 era 675000 anq 376000 ana 375000 asa 055000 aos 054000 canq 316000 ssa 155000 ssq 156000 easpbp 313000 eawpbp 312000 stca 751000 stcq 752000 stbq 552000 stba 551000 ansa 355000 ansq 356000 * 20 ic 4 ql 06 qu 02 au 01 al 05 x0 10 x5 15 x7* 37 x7 17 du 3 dl 7 xrfield 17 address-part -777601 ;777777000177 opcode-part 000000777400 ab| 100000000100 ab|2 100002000100 ab|-2 177776000100 ap| 000000000100 ap|-2 077776000100 bp| 200000000100 bp|0 200000000100 bp|1 200001000100 bp|2 200002000100 bp|-2 277776000100 bb|0 300000000100 lb|2 -277775777700 bb|2 300002000100 bb|-1 377777000100 lp| -377777777700 ab-x7 100000000117 ab-x7* 100000000137 nil-offset 12 t-offset 14 ab|store-ptr 100010000100 ab|store-op 100116000100 ab|float-store-op 100120000100 ab|nil 100012000100 ab|t 100014000100 ab|bind 100020000100 ab|unbind 100022000100 ab|errset1 100024000100 call-op 000032000020 ab|errset2 100026000100 ab|unerrset 100030000100 ab|catch1 100034000100 ab|catch2 100036000100 ab|uncatch 100040000100 ab|prolog 100042000100 ab|iogbind 100046000100 ab|badgo 100050000100 ab|throw1 100052000100 ab|throw2 100054000100 ab|signp 100056000100 ab|type-fields 100060000100 ab|return 100062000100 ab|err 100064000100 ab|cons 100072000100 ab|ncons 100074000100 ab|xcons 100076000100 ab|begin-list 100100000100 ab|append-list 100102000100 ab|terminate-list 100104000100 ab|compare 100106000100 ab|cons-string-op 100136000100 ab|create-string-descrip-op 100130000100 ab|create-varying-string-op 100140000100 ab|create-array-descrip-op 100132000100 ab|pl1-call-op 100134000100 ab|unwp1 100142000100 ab|unwp2 100144000100 ;for catch/errset compat. ab|ununwp 100146000100 ab|irest-return 100150000100 ;interrupt-restoring return. ; instructions for jump testing for plus, minus, equal, not equal. jump-tests ((l . 605000) (le . 605400) (g . 604400) (ge . 604000) (n . 600000) (e . 601000)) \-ops ((Q 506000 A) (nil 506000 A)) ; opcode table for remainder. +-ops ((Q 076000 Q) (nil 076000 nil) (A 075000 A)) --ops ((Q 176000 Q) (nil 176000 nil) (A 175000 A)) *-ops ((Q 402000 Q) (nil 402000 Q)) ; can't multiply number in A. //-ops ((Q 506000 Q) (nil 506000 Q)) ; can't divide number in A. logand-ops ((Q 376000 Q) (nil 376000 nil) (A 375000 A)) logor-ops ((Q 276000 Q) (nil 276000 nil) (A 275000 A)) xor-ops ((Q 676000 Q) (nil 676000 nil) (A 675000 A)) +$-ops ((475000) (475000)) ;fad, fad -$-ops ((575000) (575000 513000)) ; fsb, fsb-fneg *$-ops ((461000) (461000)) ; fmp, fmp //$-ops ((565000) (525000)) ; fdv, fdi lsubrhack 100116000000 ; special constant for lsubr arg binding. fixnum type shifted left 19. =71b25 216000000000 float-exponent 106000000000 =0/.0 -400000000000 fixnum-type 40047 flonum-type 20047 fixtype 400_24. flotype 200_24. atsymtype 100_24. filetype 1_24. bigtype 010_24. numtype 610_24. arraytype 2_24. atomtype 770_24. strtype 40_24. subrtype 20_24. bindargatom 4_33. bindab 0_33. bindtemp 1_33. bindliteral 3_33. bindquote 2_33. bindspecial 7_33. bindnargs 5_33. Link18 22 ;Link18 relocation code Link15 24 ;Link15 relocation code const-table-size 111. ; size of constant hash table. fcn-table-size 111. ; size of function hash table, used to detect identical calls. ) 'END ; end of compile time operations. (setq arrays nil) (setq bindtag (ncons 'bindtag) unwptag (ncons 'unwptag) errtag (ncons 'errtag) catchtag(ncons 'catchtag) progtag (ncons 'progtag) time-option nil prog-for-effs nil ) (array const-table t !const-table-size) (array fcn-table t !fcn-table-size) (putprop 'abs$ (get 'abs 'subr) 'subr) (putprop 'absfix/! (get 'abs 'subr) 'subr) (putprop 'expt$ (get 'expt 'subr) 'subr) ; declare lisp_cg_utility_ (declare (defpl1 cg-util "lisp_cg_utility_" (char(*)) (lisp) (char(*)) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp))) (%include compiler-macros) ;get macros common to pass 1 and pass 2 (%include compiler-badfns) ; include list of functions which set special variables (defun unsysp macro (x)(list 'getl (cadr x) ''(*expr *fexpr *lexpr *macro))) (defun choose-opc macro (x) (displace x (list 'cond (list '(eq AQ-state 'A) (cadr x)) (list 't (caddr x))))) (defun >3 macro (x) (displace x (list 'and (list '> (cadr x) (caddr x)) (list '> (caddr x) (cadddr x))))) (defun logor macro (x) (displace x (cons 'boole (cons 7 (cdr x))))) (defun logand macro (x) (displace x (cons 'boole (cons 1 (cdr x))))) (defun left macro (x) (displace x (list 'lsh (cadr x) 18.))) ; macro to cause output of instruction with tag specified. instruction and tag are normally constants, ; but may be expressions which evaluate to numbers. Hopefully logor will be computed at compile teim for constatns. (defun outinstag macro (x) (displace x (list 'outinst (list 'logor (cadr x) (cadddr x)) (caddr x)))) (defun outjumptag macro (x) (displace x (list 'outjump (cadr x)(list 'logor (caddr x) (cadddr x))))) (defun clearaq () ; clear the AQ, saving it if necessary. (storeaq?) ; store aq if necessary. (setq AQ nil AQ-state nil)) (defun storeaq? () ; function to see if staq temp is needed, and do it if so. (or (null AQ) ; if already clear, just do nothing. (and (not (atom (cdr AQ))) (eq (car AQ) 'quote)) ; if constant that can be easily reloaded. (memq AQ slotlist) ; or if already on stack (cond ((numberp (cdr AQ)) (damned-variable AQ)) ((eq (cdr AQ) 'idup) (damned-variable (cons (car AQ) cnt))) ; if idup is in AQ, treat it as cur var. ((not (memq AQ loadlist)))) ; if not to be loaded, or already used-up value. (saveaq)) nil) (defun put-type-in-aq () ; make sure the value in AQ is a lisp object, not numeric result. (and AQ AQ-state ; if a value is in AQ, and the state is non-nil, must load type field. (progn (cond ((eq AQ-state 'Q) (outinstag !lda (left !fixnum-type) !dl)) ((eq AQ-state 'A) (outinst !lrl (left 36.)) (outinstag !lda (left !fixnum-type) !dl)) ((eq AQ-state 'EAQ) (cv-float-to-typed)) (t (barf AQ-state "is impossible AQ-state" barf))) (setq AQ-state nil)))) ; finally, note that AQ is now a normal lisp number with type. (defun damned-variable (x) ; determine if varaible is to die now or later. (prog (temp) (setq temp -1) (mapc '(lambda (y) (and y (numberp (cdr y)) (eq (car x) (car y)) (>3 (cdr x) (cdr y) temp) (setq temp (cdr y)))) ; find most recent competing value for this var on slotlist. slotlist) (mapc '(lambda (y) (and y (numberp (cdr y)) (eq (car y) (car x)) (< temp (cdr y)) (not (> (cdr y) (cdr x))) (return nil))) loadlist) (return t))) (defun clearslotlist () ; make slotlist clear of garbage results....which might be freed soon. (mapcar '(lambda (x) (cond ((freeable x) nil) (x))) slotlist)) (defun freeable (x) ; if temp is not useful, returns t. (cond ((null x)) ; if nothing there yet, of course it is. ((atom x) nil) ; if marked by atom as already reserved. ((eq (cdr x) 'home) (and (> cnt (cdr (assq (car x) locvars))) (damned-variable (cons (car x) cnt)))) ((memq x loadlist) nil) ((numberp (cdr x)) (damned-variable x)) ((eq (cdr x) 'idup) (damned-variable (cons (car x) cnt))) (t))) (defun freetemp macro (form) (subst nil nil '(findtemp nil))) ; free, general-type temporary (defun findtemp (type) ; get a temporary of type type. (do ((tempi 0 (+ tempi 2)) (slot (or slotlist (setq slotlist (ncons nil))) ; if nothing on slotlist, must start it up (or (cdr slot) (cdr (rplacd slot (ncons nil))))) ; handle end of slotlist. (types (or slot-types (setq slot-types (ncons nil))) ; handle null slot-types. (or (cdr types) (cdr (rplacd types (ncons type)))))) ; and end of slot-types. ((and (eq (car types) type) ; must be of right type (freeable (car slot))) ; and freeable (setq slotx (rplaca slot t)) ; rplaca out whatever's there. (setq temp-size (max temp-size (+ 2 tempi))) tempi))) (defun saveaq () ; save contents of AQ in temporary. (prog (slotx ; special which is munged by findtemp. opc offset type) ; for particular store to use. (cond ((null AQ-state) (setq opc !staq offset 0 type nil)) ((eq AQ-state 'A) (setq opc !sta offset 1 type 'fixnum)) ((eq AQ-state 'Q) (setq opc !stq offset 1 type 'fixnum)) ((eq AQ-state 'EAQ) (setq opc !fst offset 1 type 'flonum)) ((barf AQ-state "is bad state for AQ to be in at this point" barf))) (outinst opc (list 'temp (+ offset (- (findtemp type) arg-height)))) (rplaca slotx AQ))) (defun clearbb () ; makes sore bb is clobberable (storebb?) (setq BB nil)) (defun storebb? () ; makes sure bb is stored on stack somewhere if necessary. (or (null BB) ; nothing in it, return (memq BB slotlist) ; already stored, return (not (memq BB loadlist)) ; not needed in future, return. (assumes only gensym results in BB) (savebb))) ; we have to save it, so do so. (defun savebb () ((lambda (slotx temp) ; for findtemp (setq temp (freetemp)) ; get a free temporary. (rplaca slotx BB) ; mark it with what we're storing (outinst !spribb (list 'temp (- temp arg-height)))) nil nil)) (defun in-aq (x) ; check to see if value is in AQ now. (or (and (numberp (cdr x)) (eq (locvalue x) 'AQ)) ; if variable value which is in AQ, then true, else (eq x AQ))) ; if the value is in AQ. (defun in-Q (x) (and (in-aq x) (memq AQ-state '(nil Q)))) (defun in-bb macro (x) ; macro, because simple. (displace x (list 'eq (cadr x) 'BB))) ; just check if BB is eq to result needed. (defun iloc (x) ; internally locate value, return address info. (cond ((numberp (cdr x)) (locvalue x)) ; locate variable value. ((eq x AQ) 'AQ) ; if already in AQ, say so. ((eq (car x) 'quote) x) ; if constant, it is trivially addressed. (t (and (eq x BB) (storebb?)) ; make sure BB contents in storage. (do ((slot slotlist (cdr slot)) (tempi 0 (+ 2 tempi))) ; scan over slots in stack. ((or (and (null slot)(barf x "lost value" barf)) (eq (car slot) x)) (list 'temp (- tempi arg-height))))))) (defun locvalue (x) ; locate variable value, searching for best value... (do ((slot slotlist (cdr slot)) (bestim nil) (besti nil) (i 0 (+ 2 i))) ((null slot) ; end of temps, see if AQ is better value. (cond ((betterval x AQ bestim) 'AQ) ; it is! (besti (list 'temp (- besti arg-height))) ; found good temp. (t (make-const (car x)) (list 'special (car x))))) ; else it must have been special (unless a bug happened) (cond ((betterval x (car slot) bestim) (setq besti i) (setq bestim (cond ((numberp (cdar slot)) (cdar slot)) (cnt))))))) (defun betterval (val place oldbestim) ; better representation of variable value checker. (and (not (atom place)) ; if place is a value. ((lambda (time placetime) ; time is value time, palcetime is checked time. (cond ((or (eq placetime 'home) (eq placetime 'dup) ; if dup in AQ, better value. (eq placetime 'idup)) ; copied out value due to a setq. (setq placetime cnt))) ; time then is current time. (and (numberp placetime) ; if a variable value, (eq (car val) (car place)) ; and this variable's value also, (not (< placetime time)) ; and is a possible candidate for having the right value, (or (null oldbestim) (not (> placetime oldbestim))))) ; and is a better candidate than the last one found, ; then it is a better value. (cdr val) (cdr place)))) (defun ilocs (x) ;locate value, which must be in storage. ;will force a staq if value is only in AQ. ((lambda (loc) ; loc is iloc(x). (cond ((eq loc 'AQ) ; and if in AQ, (storeaq?) ; make sure it is stored. ((lambda (AQ) ; now rebind AQ to nil, and iloc will find the value in storage. (iloc x)) nil)) (t loc))) (iloc x))) (defun outinst (opc oper) ; output instruction. (or (and useless-code (prog2 (tra-adjust) (not labels-to-define))) ; inhibit code here? (cond ((numberp oper) (outwrd (logor opc oper))) ((atom oper) ((lambda (lvalue) ; check to see if label already defined. (cond ((null lvalue)(outwrd (logor (left (minus pc)) !ic opc)) ;Not defined (putprop oper (cons codelist (get oper 'references)) 'references)) ((atom lvalue) ;ic-rel tag (outwrd (logor (left (- lvalue pc)) !ic opc))) (t (outwrd (logor opc (car lvalue)))))) ;absolute place (get oper 'lvalue))) ((eq (car oper) 'quote) (outwrd (cond ((eq (cadr oper) nil) (logor opc !ab|nil)) ((eq (cadr oper) t) (logor opc !ab|t)) ((or (smallnump (cadr oper)) (floatp (cadr oper))) (cons 'literal (logor opc !ic (left (- (get-literal-addr oper) pc))))) ( (logor opc !lp| (left (+ 1 (get-constant-addr oper)))))))) ((eq (car oper) 'special) (outwrd (logor opc !* !lp| (left (+ 1 (get-constant-addr (make-const (cadr oper)))))))) ((eq (car oper) 'function) (cond ((eq (cadddr oper) 'array) ;array-link (outwrd (cons 'array (logor opc !lp| (left (+ 1 (get-array-link-addr oper))))))) (t (outwrd (cons 'function (logor opc !lp| !* (left (+ 1 (get-fcn-addr oper))))))))) ((eq (car oper) 'temp) (outwrd (cons 'temp (logor opc !ap| (left (cadr oper)))))) (t (barf oper "illegal operand in instruction" barf))))) (defun outbindwrd (x y) (setq x (left (+ 1 (get-constant-addr x)))) ; get address of bound atom. (cond ((eq y 'nargs) (outwrd (logor !bindnargs x))) ((eq (car y) 'temp) (outwrd (cons 'bindtemp (logor !bindtemp x (logand 777777 (cadr y)))))) ((eq (car y) 'quote) (cond ((eq (cadr y) nil) (outwrd (logor !bindab x !nil-offset))) ((eq (cadr y) t) (outwrd (logor !bindab x !t-offset))) ((or (smallnump (cadr y)) (floatp (cadr y))) (outwrd (cons 'bindliteral (logor !bindliteral x (logand 777777 (- (get-literal-addr y) pc)))))) (t (outwrd (logor !bindquote x (+ 1 (get-constant-addr y))))))) ((eq (car y) 'special) (outwrd (logor !bindspecial x (+ 1 (get-constant-addr (make-const (cadr y))))))))) (defun tra-adjust nil ; fix t** * + 2 (and (cddr codelist) ; gotta be that long (= (logand (car codelist) !opcode-part) !tra) ; last was uncond tra (do ((x labels-to-define(cdr x)) ;scan labels (y (cdr codelist))(z)) ((null x)) (setq z (get (car x) 'references)) (cond ((memq codelist z) ; tra * + 1 (putprop (car x)(delq codelist z) 'references) (setq codelist (cdr codelist) pc (1- pc)) (return nil))) (cond ((memq y z) ;; and branching here.. (putprop (car x)(delq y z) 'references) (return t)))) (progn ;now delete the tra (setq pc (1- pc)) ; back up pc (setq codelist (cdr codelist)) ; destroy tra (cond ((numberp last-tra-target) ; was defined (rplaca codelist (logor (left (1+ (- last-tra-target pc))) (boole 1 (car codelist) 777777)))) ((atom last-tra-target) ;tag, not yet defined (putprop last-tra-target (cons codelist (get last-tra-target 'references)) 'references)) (t (rplaca codelist (logor (logand (car codelist) !opcode-part) ;absolute place (car last-tra-target))))) (rplaca codelist (boole 6 (car codelist) 1000))))) ; invert test (defun outjump (opc oper) ; special case jumps... (and (fixp oper) ;absolute jump ((lambda (sym) (putprop sym (ncons oper) 'lvalue) (setq oper sym)) (gensym))) (and (= opc !tra) ((lambda (lvalue) (cond ((null lvalue) (putprop oper (nconc labels-to-define (get oper 'synonyms)) 'synonyms) (or useless-code (setq last-tra-target oper))) (t (mapc '(lambda (x) (fix-refs x lvalue)) labels-to-define) (or useless-code (setq last-tra-target lvalue)))) ; save loc (setq labels-to-define nil)) (get oper 'lvalue))) (outinst opc oper) ; first output the code, (and (= opc !tra) (setq useless-code t))) ; and then check to see if we should inhibit code to next label... (defun outwrd (wrd) ; output any type of code word. (mapc '(lambda (x) (fix-refs x pc)) labels-to-define) (cond (labels-to-define (setq labels-to-define nil useless-code nil))) (setq pc (1+ pc)) (setq codelist (cons wrd codelist))) (defun define-tag (tag) ; define the value of a tag, to be the current pc. (cond ((and useless-code (not labels-to-define)) ; if preceded by unconditional transfer, ignore state of machine. (setq slotlist (get tag 'level) AQ-state (get tag 'AQ-state) AQ (get tag 'AQ) BB (get tag 'BB)) (nconc slotlist (do ((i (- (lsh temp-size -1) (length slotlist)) (1- i)) (val nil (cons nil val)))((= i 0) val)))) (t (or (and (eq AQ (get tag 'AQ)) (eq AQ-state (get tag 'AQ-state))) ; set AQ from combined states of all jumps to label, and current . (setq AQ nil AQ-state nil)) (or (eq BB (get tag 'BB)) ; set BB from combination of all jumps to tag. (setq BB nil)) ((lambda (tagl) ; tagl = (get tag 'level) (setq slotlist (or slotlist (and tagl (ncons nil)))) ; make sure slotlist has elements if ; tag level does... (do ((slot slotlist ; force slotlist to intersection of states. (cdr (cond ((and (cdr slot1) (null (cdr slot))) (rplacd slot (ncons nil))) ; lengthen short slotlist (t slot)))) ; otherwise go down it. (slot1 tagl (cdr slot1))) ((null slot1) (map '(lambda (x) (rplaca x nil)) slot)) ; nil-ify rest of slotlist. (or (eq (car slot) (car slot1)) (rplaca slot nil)))) (get tag 'level)))) ; (cond ((not (= (length slotlist) (lsh temp-size -1))) (barf temp-size "wrong slotlist size - define-tag" barf))) ; above line did not work when slotlist was too short...which can occur. (setq labels-to-define (cons tag labels-to-define))) ; push tag on labels-to-define, not bumping pc. (defun fix-refs (lab val) (prog (references synonyms) (setq references (get lab 'references)) (setq synonyms (get lab 'synonyms)) (and references (prog2 (cond ((atom val) ;ic-rel tag (mapc '(lambda (x) (rplaca x (+ (car x) (left val)))) references)) (t (mapc '(lambda (x)(rplaca x (logor (car val)(logand (car x) !opcode-part)))) references))) (remprop lab 'references))) (and synonyms (prog2 (mapc '(lambda (x) (fix-refs x val)) synonyms) (remprop lab 'synonyms))) (return (putprop lab val 'lvalue)))) (defun get-pl1-link (name) ((lambda (address) (setq pl1-link-size (+ address 2)) (setq pl1-link-list (cons name pl1-link-list)) (cons 'pl1-link (logor !tralink (left address)) )) ; go there (operator sets lp) pl1-link-size)) ;;; functions to assign addresses to literals and constants referenced by the code. (defun get-literal-addr (const) ; takes arg in standard "uniquized" representation for constant, returns addr. (cond ((cddr const)) ; cddr is address if already assigned. (t (rplacd (cdr const) literal-size) ; assign new address (setq literal-size (+ 2 literal-size) ; and up the length of literals. literal-list (cons const literal-list)) (cddr const)))) (defun get-constant-addr (const) ; takes arg in standard "uniquized" representation for constant, returns addr. (cond ((cddr const)) ; cddr is address if already assigned. (t (rplacd (cdr const) constant-size) ; assign new address (setq constant-size (+ 2 constant-size) ; and up the length of constants. constant-list (cons const constant-list)) (cddr const)))) (defun get-fcn-addr (const) ; assign address for function link, if not already assigned. (cond ((cddddr (cdr const))) ; if already assigned, address is cdddddr of function representation. (t (rplacd (cddddr const) fcn-size) ; put new address in representation for future use. (setq fcn-size (+ fcn-size 2) ; 2 words allocated for link. functions-called (cons const functions-called)) ; note that we have to make the link later. (- fcn-size 2)))) ; return the address of the link. (defun get-array-link-addr (x) ;assign address for array link (cond ((cddddr (cdr x))) ;already assigned. (t (rplacd (cddddr x) array-size) ;insert address (setq array-size (+ array-size 4)) ;allow for 4-word block. (setq array-links (cons x array-links)) (- array-size 4)))) ;return the address of the array-link. ;;; routines for the compilation of arithmetic functions. ;;; generation of inline arithmetic requires special handling. (defun outarith (opc addr) ; output arithmetic instruction...specialized operand handling. (and useless-code (tra-adjust)) (outwrd (cond ((eq (car addr) 'quote) ; literal operands can be handled very neatly, often. ((lambda (num) (cond ((not (smallnump num)) (barf addr "bad fixnum function operand" data)) ((= 0 (logand 777777 num)) (logor opc !du num)) ; du-type operand ((= 0 (logand (left 777777) num)) (logor opc !dl (left num)));dl-type (t (cons 'literal (logor opc !ic (left (- (get-literal-addr addr) pc -1))))))) (cadr addr))) ((eq (car addr) 'special) ; set up special value. (outinst !eppbp addr) ; get pointer to it (logor opc !bp|1)) ((eq (car addr) 'temp) ; temporary location. (cons 'temp (logor opc !ap| (left (1+ (cadr addr)))))) (t (barf addr "illegal arithmetic operand" barf))))) (defun get-fixnum (x) ; get fixnum value into register. ((lambda (locx) (cond ((not (eq locx 'AQ)) (loadarith x locx))) ; if not in register load it. (remove x)) (iloc x))) (defun get-fixnum-commu (x y) ; get fixnum for commutative function. ((lambda (locx locy) (cond ((eq locx 'AQ)) ; in register, do nothing. ((eq locy 'AQ) (setq x (prog2 nil y (setq y x)))) ; y in reg, remove y, give x ; avoid loading x if it is constant - less code to load var. ((and (not (atom locx))(eq (car locx) 'quote)) (loadarith y locy)(setq x (prog2 nil y (setq y x)))) (t (loadarith x locx))) ; neither in register, get x in register. (remove x) y) ; return unloaded value name (iloc x) (iloc y))) (defun loadarith (x locx) ; load arithmentic typ value into AQ from storage. (clearaq) ; first make sure nothing important in AQ. (cond ((eq (car locx ) 'special) ; if special, best load is ldaq. (outinst !ldaq locx) (setq AQ (cons (car x) 'dup))); AQ-state was set to nil by clearaq. ((progn (outarith !ldq locx) (setq AQ-state 'Q) (eq (car locx) 'temp)) (setq AQ (contents (+ (cadr locx) arg-height)))) (t (setq AQ x)))) ; if not temp, set value name. (defun comparith (commu optable args) ; commutative switch, table of operations, arguments. (cond ((null (cdr args)) ; if no arguments but 1, return argument. (setq args (comp (car args))) (remove args) ; make sure result not on loadlist. args) ((do ((result (comp (car args))) ; first result is the car of the arguments. (args (cddr args) (cdr args)) ; move down arg list one at a time. (newarg (comp (cadr args)) (comp (car args)))) (nil) ; no end test at beginning of loop. (cond (commu (setq newarg (get-fixnum-commu result newarg))) ; if either in aq, get other into newarg. (t (get-fixnum result))) ; if not commutative, must get first arg. (storeaq?) ; make sure necessary copies of result are in storage. (cond ((setq result (assq AQ-state optable))) ; get proper operation from optable and AQ-state. ((eq (car (setq result (car optable))) ; if not in ok state, get preferred target state. 'Q) ; if Q, assume fixnum operand. (cond ((null AQ-state)) ; nil is essentially equal to Q. ((eq AQ-state 'A) (outinst !lrl (left 36.))) (t (barf AQ-state "cannot be made into fixnum!" barf)))) ((eq (car result) 'A) ; require that result be in A. (cond ((or (null AQ-state) (eq AQ-state 'Q)) (outinst !lls (left 36.))) (t (barf AQ-state "cannot be made into fixnum!" barf)))) (t (barf AQ-state "cannot be made into fixnum!" barf))) (outarith (cadr result) (ilocs newarg)) ; put out instruction from optable. (remove newarg) (setq AQ-state (caddr result)) ; get new AQ-state from optable. (setq result (ncons (gensym)) AQ result) (putprop (car result) 'fixnum 'number) (and (null args) (return result)) (setq loadlist (cons result loadlist)))))) ; make sure result stays around till needed. ;;; routine to negate a fixnum correctly... (defun negate-fixnum (x) ; gets name for result to be negated. ((lambda (locx) (cond ((eq locx 'AQ) (remove x) ; once in AQ, don't need it here anymore. (storeaq?) (cond ((not (eq AQ-state 'A)) (outinst !lls (left 36.)))) (setq AQ-state 'A) (outinstag !neg 0 !du)) (t (clearaq) (outarith !lcq locx) ; negate from storage. (remove x) (setq AQ-state 'Q)))) (iloc x)) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) AQ) ;;; routine to compile lsh and rot inline... (defun compshift (lsh? val shift) ; lsh/rot switch, value to be shifted, amount. (cond ((and (eq (car shift) 'quote) ; check for constant second operand. (not (smallnump (cdr shift)))) (remove shift) ; don't need to load shift in constant case. (get-fixnum val) ; get the value to be shifted in a register. (storeaq?) ; make sure it is mungable (setq shift (cadr shift)); get shift amount (cond ((or (not (smallnump shift)) ; make sure amount is allowable shift amount (> shift 36.) (< shift -36.)) (barf shift "excessive shift. Max = 36." data)) (lsh? (cond ((< shift 0) (setq shift (- 0 shift) ; negative shift direction... val (choose-opc !arl !qrl))) ; get right opcode (t (setq val (choose-opc !als !qls))))) (t (cond ((< shift 0) (setq shift (+ shift 36.)))) (setq val (choose-opc !alr !qlr)))) (outinst val (left shift))) ; finally, output the right instruction. (t (setq shift (prog2 0 (iloc shift) (remove shift))) ; locate shift, remove from loadlist (cond ((eq shift 'AQ) ; if shift value in AQ, move to x0 (cond ((eq AQ-state 'A) (outinstag !eax0 0 !al)) ; from A, (t (outinstag !eax0 0 !ql)))) ; or from Q as necessary. (t (outarith !lxl0 shift))) ; otherwise, load from storage... (get-fixnum val) ; get value into AQ (storeaq?) ; make sure it is unshared (cond (lsh? (cond ((eq AQ-state 'A) (outinstag !ldq 0 !dl)) ; move value into A, zero Q. (t (outinst !lls (left 36.)))) (setq AQ-state 'Q) ; after shift, value will be in Q, type bits destroyed. (outinstag !llr (left 36.) !x0)) ; takes care of negative values, as well as positive (t (outinstag (choose-opc !alr !qlr) (left 36.) !x0))))) ; and so does this. (setq AQ (ncons (gensym))) ; return name for result in AQ. (putprop (car AQ) 'fixnum 'number) AQ) ;;; functions which handle floating point computations. (defun outfloat (opc addr) ; outputs a floating point instruction. (and useless-code (tra-adjust)) (outwrd (cond ((eq (car addr) 'quote) (cons 'literal (logor opc !ic (left (- (get-literal-addr addr) pc -1))))) ((eq (car addr) 'special) (outinst !eppbp addr) ; make float number addressable (logor opc !bp|1)) ((eq (car addr) 'temp) (cons 'temp (logor opc !ap| (left (1+ (cadr addr)))))) ((barf addr "illegal float operand" barf))))) (defun get-flonum (x) ((lambda (locx) (cond ((not (eq locx 'AQ)) (loadfloat x locx)) ((not (eq AQ-state 'EAQ)) (loadfloat x (ilocs x)))) ; if not in float format, get it from storage. (remove x)) (iloc x))) (defun loadfloat (x locx) ; output a load instruction to locx. (clearaq) (outfloat !fld locx) ; the instruction. (setq AQ-state 'EAQ) (cond ((eq (car locx) 'special) (setq AQ (cons (car x) 'dup))) ((eq (car locx) 'temp) (setq AQ (contents (+ (cadr locx) arg-height)))) (t (setq AQ x)))) (defun compfloat (optable args) ; output code for most floating point operations. (cond ((null (cdr args)) (setq args (comp (car args))) (remove args) args) ((do ((result (comp (car args))) (table (car optable) (car optable)) (args (cddr args) (cdr args)) (newarg (comp (cadr args)) (comp (car args)))) (nil) (cond ((and (in-aq result) (eq AQ-state 'EAQ))) ((and (in-aq newarg) (eq AQ-state 'EAQ)) (setq result (prog2 nil newarg (setq newarg result)) table (cadr optable))) (t (loadfloat result (ilocs result)))) (remove result) (storeaq?) (outfloat (car table) (ilocs newarg)) (and (cdr table) (outinst (cadr table) 0)) (remove newarg) (setq result (ncons (gensym))) (putprop (car result) 'flonum 'number) (setq AQ result) (and (null args) (return result)) (setq loadlist (cons result loadlist)))))) (defun negate-flonum (x) (get-flonum x) ; get it in EAQ. (storeaq?) (outinst !fneg 0) (remove x) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) (defun cv-float-to-typed () ; function to convert float in EAQ to typed number in AQ. ((lambda (aq-cont) (setq loadlist (cons aq-cont loadlist)) ; make sure we are known to need aq. (outinst !ldaq (ilocs aq-cont)) (remove aq-cont) ; pop back off loadlist. (setq AQ-state nil)) (cond ((memq (cdr AQ) '(dup idup)) (cons (car AQ) cnt)) ; make sure ok to put away. (t AQ)))) (defun gotvalue (x) ; predicate to test to see if variable value x has alreayd been gotten. (do ((slot slotlist (cdr slot))) ((null slot) (goodval x AQ)) ; if not on slotlist, check AQ. (and (goodval x (car slot)) (return t)))) ; hack used here -- if any value for variable ; has been saved since it was referenced, a good value ; must exist, so don't have to check as much. (defun goodval (x y) ; see if y contains a value for x which is later in time than x referenced. (and y (eq (car y) (car x)) (or (memq (cdr y) '(idup dup)) ; (idup dup) must be later. (and (numberp (cdr y)) ; else must be a saved value (not (< (cdr y) (cdr x))))))) ; which is later in time. (defun cleanup-var-loads () ; makes sure all variables mentioned on loadlist have been put on slotlist or in AQ. (do ((x loadlist (cdr x))) ((null x)) (and (numberp (cdar x)) ; if load value is variable value. (not (gotvalue (car x))) ; and haven't loaded it yet (savevalue (car x)))) ; then must save it. (fixidups)) ; fix up idups, thus closing off past time section. (defun cleanup-special-var-loads () ; makes sure all special variables mentioned on loadlist have been put on slotlist or in AQ. (do ((x loadlist (cdr x))) ((null x)) (and (numberp (cdar x)) ; if load value is variable value. (specialp (caar x)) ; and is that of a special var, (not (gotvalue (car x))) ; and haven't loaded it yet (savevalue (car x)))) ; then must save it. (fix-special-idups)) ; fix up idups, thus closing off past time section. (defun savevalue (x) ; save variable value. (clearaq) (setq x (car x)) (or (and (eq (car AQ) x) (eq (cdr AQ) 'dup)) ; if just a duplicate of home is in AQ, don't have to do anything. (do ((slot slotlist (cdr slot)) (tempi 0 (+ 2 tempi))) ((null slot) (outinstag !ldaq (make-const x) !*)) (and (car slot) (eq (caar slot) x) (eq (cdar slot) 'home) (return (outinst !ldaq (list 'temp (- tempi arg-height))))))) (setq AQ (cons x 'idup))) ; AQ-state has been set by clearaq, to nil. (defun fixidups () ; turn all idup's into numeric indicators = to cnt. (mapc '(lambda (x) (and (not (atom x)) (eq (cdr x) 'idup) (rplacd x cnt))) slotlist) (and AQ (memq (cdr AQ) '(idup dup)) (rplacd AQ cnt))) (defun fix-special-idups () ; turn all special-idup's into numeric indicators = to cnt. (mapc '(lambda (x) (and (not (atom x)) (eq (cdr x) 'idup) (specialp (car x)) (rplacd x cnt))) slotlist) (and AQ (memq (cdr AQ) '(idup dup)) (specialp (car AQ)) (rplacd AQ cnt))) (defun cleanup-var-load (x) ; cleanup loadlist references to variable value x. (mapc '(lambda (y) (and (numberp (cdr y)) (eq (car y) x) (or (gotvalue y) (savevalue y)))) loadlist) ; make sure all refs to x on loadlist are satisfied now. (mapc '(lambda (y) (and (not (atom y)) (eq (car y) x) (eq (cdr y) 'idup) (rplacd y cnt))) slotlist) (and AQ (eq (car AQ) x) (memq (cdr AQ) '(idup dup)) (rplacd AQ cnt))) ; function to make a call to a lisp function. (defun make-call (functional fntype args) ; apply functional to args... (prog (nargs cargs temp snap? type) ; cargs = compiled args. nargs, temp tempoararies. (cond ((eq fntype 'fsubr) (setq nargs 2) (setq bump-arg-height (+ bump-arg-height 2)) ; more space for args needed (get-in-aq (comp (list 'quote args))) (storearg -2)) (t (setq nargs (lsh (length args) 1)) (setq bump-arg-height (+ bump-arg-height nargs)) (do ((scan args (cdr scan)) (tempi (minus nargs) (+ 2 tempi)) (val)) ((null scan)) ; scan through all args (cond ((and (in-aq (setq val (comp (car scan)))) (not (eq AQ-state 'EAQ))) ; if in AQ, then store it now! (remove val) (storearg tempi)) ((in-bb val) (remove val) (storearg-bb tempi)) ; if in bb register, store now too! ((setq temp (assq val cargs)) ; if val is already the same as before, (remove val) ; remove this entry from loadlist, since one is all we need. (rplacd temp (cons tempi (cdr temp)))) ; add to list of places where val is stored. ((setq cargs (cons (list val tempi) cargs))))) ; else add new val to be stored. (do scan cargs (cdr scan) (null scan) (get-in-aq (caar scan)) ; get val in AQ. (mapc 'storearg (cdar scan))))) ; store the arg that many times. a (cond ((atom functional) (cond ((setq type (get functional 'numfun)) ; if number function, get known type. (setq type (car type)))) (setq temp (make-const functional) snap? t)) (t (cond ((eq (car functional) '*subr-ptr) ;calling a subr pointer (setq type (cadr functional) snap? 'subrcall) (or (eq type 'fixnum) (eq type 'flonum) (setq type nil)) (setq functional (comp (caddr functional))))) (setq temp (iloc functional)) (cond ((eq temp 'AQ) (clearaq) (go a)) ((eq (car temp) 'special) (cleanup-var-load (cadr temp)) (go a))))) (cond ((or (not (atom functional)) ; if function may change special vars, (not (sysp functional)) ; then we want to load any that we are waiting for values of. (memq functional (badfns))) (cleanup-special-var-loads)) ) (clearaq) (clearbb) (cond ((eq fntype 'lsubr) (outinst !eax5 (minus (left nargs))))) ; if lsubr, pass arg count. (cond ((eq snap? 'subrcall) ;indirect through subr pointer (cond ((numberp temp) (outinstag !eppbp temp !*)) (t (outinst !eppbp temp) (outinstag !eppbp !bp|0 !*) )) (outinst !tspbp !bp|1)) (t (outinst !tspbp (get-function temp snap? fntype (lsh nargs -1))) )) (setq arg-height (- arg-height nargs)) (cond ((not (atom functional)) (remove functional))) ; if was on loadlist, remove function. (setq AQ (ncons (gensym))) ; AQ-state has been set by clearaq above. (cond (type (putprop (car AQ) type 'number))) ; remember type of result. (return AQ))) (defun get-function (x snap? type nargs) ; function to maintain unique function representation. ((lambda (hash bucket) ; some temp variables. (setq bucket (fcn-table hash)) (do ((scan bucket (cdr scan))) ((null scan) (store (fcn-table hash) (cons (setq x (list 'function x snap? type nargs)) ; make unique representation if not found bucket)) x) (and (eq x (cadar scan)) ; if all 4 components are eq, then use this existing representation. (eq snap? (caddar scan)) (eq type (cadddr (car scan))) (eq nargs (cadddr (cdar scan))) (return (car scan))))) (abs (\ (cond ((eq (car x) 'temp) (cadr x)) ; if in a temp, hash by temp offset. (t (sxhash (cadr x)))) ; otherwise, must be (quote < > ), hash by object. !fcn-table-size)) nil)) (defun storearg (x) (force-arg-height) ; force arg-height to be bumped up... (put-type-in-aq) (outinst !staq (logor !ap| (left (logand x 77777))))) ; store an argument relative to the top of the marked pdl. (defun storearg-bb (x) ; store argument from bb register. (force-arg-height) (outinst !spribb (logor !ap| (left (logand x 77777))))) (defun force-arg-height () ; force arg height to required value... (cond ((not (zerop bump-arg-height)) ; if need to get the space we are to store into... (outinst !eppap (logor !ap| (left (logand 77777 bump-arg-height)))) (setq arg-height (+ arg-height bump-arg-height)) ; now the real arg-height is here. (setq bump-arg-height 0)))) (defun get-in-aq (x) ; force an argument into the aq. ((lambda (y) (cond ((eq y 'AQ) (put-type-in-aq)) ((and (eq (car y) 'quote) ;optimize load of fixnum constant (smallnump (cadr y)) (not AQ-state) ; must be typed (cond ((eq (car AQ) 'quote) (smallnump (cadr AQ))) (t (eq (get (car AQ) 'number) 'fixnum))) (progn (clearaq)(setq AQ y)(outarith !ldq y) t))) ((prog2 (clearaq) (eq (car y) 'special)) (outinst !ldaq y) ; the clearaq sets AQ-state to nil... (setq AQ (cons (car x) 'dup))) ((prog2 (outinst !ldaq y) (eq (car y) 'temp)) (setq AQ (contents (+ (cadr y) arg-height)))) (t (setq AQ x))) (remove x)) ; delete x from loadlist. (iloc x))) (defun remove(x) (setq loadlist (delq x loadlist 1))) (defun contents (x) (do ((i 0 (+ 2 i))(temp slotlist (cdr temp))) ((= i x) (cond ((eq (cdar temp) 'home) (cons (caar temp) 'dup)) (t (car temp)))))) ; get contents of temp at address... (defun comp (x) ((lambda (effs) (comp0 x)) nil)) ; compile for value (free var effs signifies this) (defun compe (x) ((lambda (effs) (comp0 x)) t)) ; compile for effect. (defun comp0 (x) ; first pass of code gen. makes a value descriptor. ((lambda (y) (cond ((atom x) (setq cnt (1+ cnt)) ; update time counter when var is referenced, (cond ((memq x null-var-list) ; if variable is recently bound to nil, just return nil. (and (get x 'number) (barf x "is a number, which has been bound to nil" data)) (and (null effs) (setq y (make-const nil)))) ((null effs) (setq y (cons x cnt))))) ((eq (car x) 'quote) (and (not effs) (setq y (get-const x)))) ; constant value is uniformly represented in pass2 ((setq y (compform (car x) (cdr x))))) (and (not effs) (setq loadlist (cons y loadlist)) y)) nil)) (defun make-const (x) ; function to uniquize the representation of a constant. (cond ((eq x nil) '(quote nil)) ((eq x t) '(quote t)) (t ((lambda (hash bucket) ; some temporary variables. (setq bucket (const-table hash)) ; get hash table bucket. (do ((scan bucket (cdr scan))) ; look down bucket for already created representation. ((null scan) ; when no more... (store (const-table hash) (cons (setq x (list 'quote x)) bucket)) ; put newly created representation in bucket. x) ; return new representation. (cond ((equal (cadar scan) x) (return (car scan)))))) (abs (\ (sxhash x) !const-table-size)) nil)))) (defun get-const (const) ; given (quote ), get unique representation. (make-const (cadr const))) (defun compform (x y) ;compute value of form... ((lambda (fnprop) (cond ((not (atom x)) (cond ((eq (car x) 'lambda) (complambda x y)) ; do lambda compile. ((and (eq (car (setq x (comp x))) 'quote) ; if constant result, (not (smallnump (cdr x))) ; (make sure not (quote . 5) or something) (eq (typep (cadr x)) 'symbol)) ; if other quoted thing, pass 1 has not examined ; it so we can't optimize it here unfortunately. (remove x) ; don't need to load function, so forget that; (compform (cadr x) y)) ; then treat as if it were a form with the fn at car. (t (make-call x 'lsubr y)))) ; make the call as lsubr because best linking can occur. ((setq fnprop (getl x '(subr fsubr lsubr expr fexpr *expr *fexpr *lexpr *array array))) (setq fnprop (car fnprop)) ; get type of function applied. (cond ((and (eq fnprop 'subr) (sysp x)) ; if system subr, check its type... (compsubr x y)) ((and (eq fnprop 'lsubr) (sysp x)) (complsubr x y)) ((and (eq fnprop 'fsubr) (sysp x)) (compfsubr x y)) ((memq fnprop '(array *array)) (comparray x y)) ((memq fnprop '(expr *expr)) (make-call x 'subr y)) ((memq fnprop '(fexpr *fexpr)) (make-call x 'fsubr y)) ((eq fnprop '*lexpr) (make-call x 'lsubr y)) (t (barf x " undefined in pass2" barf)))) ((memq x arrays) ; if array, that was mentined and created at top level. (make-call x 'subr y)) ((eq x '*unmkd-push) ; special forms for defpl1 follow... (outinstag !eax7 (left (car y)) !x7)) ((eq x '*unmkd-pop) (outinstag !eax7 (left (- (car y))) !x7)) ((eq x '*cons-string) (comp-cons-string y)) ((eq x '*pack-ptrs) (comp-pack-ptrs y)) ((eq x '*unpack-ptrs) (comp-unpack-ptrs y)) ((eq x '*pl1call) (comp-pl1-call y)) ((or (specialp x) (memq x bvars)) ; if functional value of atom, then compile a call... (make-call (comp x) 'subr y)) ; to it as a subr. if it is an fsubr, you lose. (t (barf x "undefined in pass 2" barf)))) ; complain nil)) (defun compsubr (x y) ; compile a call to a system subr. (cond ((eq x 'set) (compset (comp (car y)) (comp (cadr y)))) ; the set function. ((eq x 'rplaca) (comrplaca (comp (car y)) (comp (cadr y)))) ((eq x 'rplacd) (comrplacd (comp (car y)) (comp (cadr y)))) ((eq x 'memq) (compmemq (comp (car y)) (comp (cadr y)))) ((eq x 'return) (compreturn (car y)(cadr y))) ((memq x '(stringp ; predicate...returns arg if true. < > =)) ; or comparison, which might need call. (setq x (compred (cons x y) t t nil)) ; test and load both t forces this to work...see compred. (get-in-aq (comp '(quote nil))) ; alternate result. (define-tag x) (or AQ (setq AQ (ncons (gensym))))) ; AQ-state has been maintained by define-tag. ((memq x '(null eq zerop plusp minusp atom subrp arrayp definedp boundp fixp floatp smallnump bigp numberp symbolp filep)) ; pred, in-line. (setq x (compred (cons x y) nil nil nil)) ; compile the predicate call. (get-in-aq (comp '(quote t))) ; if predicate true, load t. (outjump !tra (setq y (level-tag nil))) ; and jump to end of code for subr. (and x (define-tag x)) ; if jump was to tag, define that tag (get-in-aq (comp '(quote nil))) ; and make sure nil is in AQ. (define-tag y) ; define the end tag, (or AQ (setq AQ (ncons (gensym))))) ; if AQ has good value remember, else new name. ; AQ-state maintained by define-tag. ((get x 'carcdr) (compcarcdr x y)) ((eq x 'ncons) (get-in-aq (comp (car y))) ; load up arg (clearbb) (outinstag !tspbp !ab|ncons !*) (setq BB (ncons (gensym)))) ((eq x 'cons) (get-in-aq (comp (car y))) ; get first arg loaded (clearbb) (outinstag !tspbp !ab|cons !*) (setq x (ncons (gensym)) ; get result name for cons BB x ; remember where it is loadlist (cons x loadlist)) (setq y (comp (cadr y))) ; compute second arg (cond ((in-bb y) ; see if secondd arg inb (outinstag !eppbp (ilocs x) !*) ; get ptr to cons (outinst !spribb !bp|2) ;store second arg in cdr. (remove y)) (t (get-in-aq y) ; load arg by default into aq (cond ((not (in-bb x)) (clearbb) (outinstag !eppbb (ilocs x) !*) (setq BB x))) (outinst !staq !bb|2))) (remove x) x) ((eq x 'xcons) (get-in-aq (comp (car y))) ; get first arg in q (clearbb) (outinstag !tspbp !ab|xcons !*) (setq BB (ncons (gensym)) x BB loadlist (cons x loadlist)) (get-in-aq (comp (cadr y))) (cond ((in-bb x) (outinst !staq !bb|0)) (t (outinstag !staq (ilocs x) !*))) (remove x) x) ((eq x '1+) (get-fixnum (comp (car y))) ; get the value in AQ, no type needed. (storeaq?) ; make sure value is stored. (cond ((eq AQ-state 'A) ; compile the add to the right register. (outinstag !ada 1_18. !dl)) (t (outinstag !adq 1_18. !dl))) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) ; mark value type. AQ) ((eq x '1-) (get-fixnum (comp (car y))) (storeaq?) ; make sure AQ is freeable for new result. (cond ((eq AQ-state 'A) ; if in A, add to A. (outinstag !sba 1_18. !dl)) (t (outinstag !sbq 1_18. !dl))) (setq AQ (ncons (gensym))) ; and return new result. (putprop (car AQ) 'fixnum 'number) ; remember type of this value. AQ) ((eq x '\) ; fixnum only remainder subr. (comparith nil !\-ops y)) ; just use super-good inline code maker. ((eq x 'lsh) ; shifting subr (compshift t (comp (car y)) (comp (cadr y)))) ((eq x 'rot) ; rotating subr (compshift nil (comp (car y)) (comp (cadr y)))) ((eq x 'ifix) (get-flonum (comp (car y))) (storeaq?) (outinstag !ufa !=71b25 !du) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) (setq AQ-state 'Q) AQ) ((eq x '1+$) (get-flonum (comp (car y))) (storeaq?) (outfloat !fad (make-const 1.0)) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) ((eq x '1-$) (get-flonum (comp (car y))) (storeaq?) (outfloat !fsb (make-const 1.0)) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) ((eq x 'minus) ; if know this to be fixnum negation, cna do well. (setq x (comp (car y))) ; compute argument. (cond ((eq (car x) 'quote) (remove x) (make-const (minus (cadr x)))) ((eq 'fixnum (get (car x) 'number)) ; if fixnum result, then... (negate-fixnum x)) ((eq 'flonum (get (car x) 'number)) ; if flonum result, can always win. (negate-flonum x)) (t (call-1-argument-subr x 'minus)))) ((eq x 'float) ; convert to floating (setq x (comp (car y))) (cond ((eq (car x) 'quote) (remove x) (make-const (float (cadr x)))) ((eq 'flonum (setq y (get (car x) 'number))) (remove x) x) ((eq 'fixnum y) ; here is the in-line case. (get-fixnum x) (storeaq?) ; save whatever's about to be clobbered. (cond ((eq AQ-state 'A) (outinstag !ldq 0 !dl)) (t (outinst !lls (left 36.)))) (outinstag !lde !float-exponent !du) (outinstag !fad !=0/.0 !du) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) (setq AQ-state 'EAQ) AQ) (t (setq x (call-1-argument-subr x 'float)) ; call float subr (putprop (car x) 'flonum 'number) x))) ((memq x '(abs abs$ absfix/!)) ; can do absolute value in line. (setq x (comp (car y))) ; compute arg. (cond ((eq (car x) 'quote) (remove x) (make-const (abs (cadr x)))) ; constant result computed now. ((eq 'fixnum (setq y (get (car x) 'number))) (get-fixnum x) ; make it in register (storeaq?) ; and make it clobberable. (cond ((eq AQ-state 'A) (outinstag !cmpa 0 !dl)) ; we want result in A, sign in register. (t (outinst !lls (left 36.)) ; this will handle moving it from Q, setting sign. (setq AQ-state 'A))) (outjump !tpl (setq y (level-tag nil))) ; jump over next inst. (outinst !neg 0) (define-tag y) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) AQ) ((eq 'flonum y) (get-flonum x) (storeaq?) (outinstag !fcmp !=0/.0 !du) (outjump !tpl (setq y (level-tag nil))) ; jump if positive around negating. (outinst !fneg 0) (define-tag y) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) (t (call-1-argument-subr x 'abs)))) ((eq x 'expt$) ; special marked expt... always results in flonum (setq x (make-call 'expt 'subr y)) (putprop (car x) 'flonum 'number) x) (t (make-call x 'subr y)))) (defun call-1-argument-subr (arg subr) (get-in-aq arg) (setq bump-arg-height (+ 2 bump-arg-height)) (storearg -2) (clearaq) (clearbb) (outinst !tspbp (get-function (make-const subr) t 'subr 1)) (setq arg-height (- arg-height 2)) ; subr pops off arg. (setq AQ (ncons (gensym)))) (defun complsubr (x y) ; compile a call to a system lsubr... this can be much improved! (cond ((eq x 'progn) ; if progn, can do good job easily. (do ((scan y (cdr scan))) ((null (cdr scan)) (progn (setq scan (comp0 (car scan))) (or effs (remove scan)) scan)) (compe (car scan)))) ((eq x 'prog2) ; prog2 is also easy. (compe (car y)) ; first arg for effect. (setq x (comp0 (cadr y))) ; remember second result. (mapc 'compe (cddr y)) ; compile rest of things for effect. (or effs (remove x)) ; if not for effect, must remove to prevent adding twice to loadlist. x) ; return second result. ((eq x '+) ; fixnum add (cond ((null y) (get-const ''0)) ; no arguments returns identity. (t (comparith t !+-ops y))));let comparith do all the work. ((eq x '-) (cond ((null y) (get-const ''0)) ; no arguments at all. ((null (cdr y)) (negate-fixnum (comp (car y)))) ; one argument to be negated. (t (comparith nil !--ops y)))) ; let comparith work it out. ((eq x '*) (cond ((null y) (get-const ''1)) ; no arguments returns identity. (t (comparith t !*-ops y)))) ((eq x '//) (cond ((null y) (get-const ''1)) ; no arguments returns identity element. ((null (cdr y)) (comparith nil !//-ops (cons ''1 y))) (t (comparith nil !//-ops y)))) ((eq x 'boole) (cond ((or (atom (car y)) ; not a constant argument, let lsubr be called. (not (eq (caar y) 'quote))) (make-call 'boole 'lsubr y)) ((= (setq x (cadar y)) 1) (comparith t !logand-ops (cdr y))) ((= x 6) (comparith t !xor-ops (cdr y))) ((= x 7) (comparith t !logor-ops (cdr y))) (t (barf y "unprocessed boole argument list" barf)))) ((eq x '+$) (cond ((null y) (make-const 0.0)) (t (compfloat !+$-ops y)))) ((eq x '-$) (cond ((null y) (make-const 0.0)) ((null (cdr y)) (negate-flonum (comp (car y)))) (t (compfloat !-$-ops y)))) ((eq x '*$) (cond ((null y) (make-const 1.0)) (t (compfloat !*$-ops y)))) ((eq x '//$) (cond ((null y) (make-const 1.0)) ((null (cdr y)) (compfloat !//$-ops (cons ''1.0 y))) (t (compfloat !//$-ops y)))) ((memq x '(list list*)) ; do in-line expansion of list. (compile-list-and-list* x y (length y))) (t (make-call x 'lsubr y)))) (defun compile-list-and-list* (x y len) (cond ((< len 2)(barf y "less than 2 arg list/list*" barf)) ((= len 2) (and (eq x 'list*)(barf y "2 args to list*" barf)) (get-in-aq (comp (car y))) (clearbb) (outinstag !tspbp !ab|cons !*) (setq x (ncons (gensym)) BB x loadlist (cons x loadlist)) ; preserve result. (get-in-aq (comp (cadr y))) ; compile second arg (clearbb) (outinstag !tspbp !ab|ncons !*) ; generate second cell. (outinstag !eppbp (ilocs x) !*) ; use bp, bb has been lost anyway (outinst !spribb !bp|2) ;store result into cdr of first one. (remove x) ; don't need result no more x) ; unless caller does (t ; list/list* > 2 args (get-in-aq (comp (car y))) ; get first arg (force-arg-height) ; and make sure ap is correct, (clearbb) ; because operator moves it, clobbers bb too. (outinstag !tspbp !ab|begin-list !*) (setq arg-height (+ arg-height 2)) (let ((result (ncons (gensym)))) ; give name to result (setq BB result) ; Result now in BB (setq loadlist (cons result loadlist)) ; Make sure result stays around (do rest (cdr y) (cdr rest) ; do all but last arguments (and (null (cdr rest)) (setq y rest)) (get-in-aq (comp (car rest))) ; get the argument (clearbb) ; get the bb cleared (outinstag !tspbp !ab|append-list !*)) (get-in-aq (comp (car y))) ; get last argument (cond ((eq x 'list) (clearbb) ; operator clobbers bb (outinstag !tspbp !ab|terminate-list !*)) (t ;This is list*... (outinstag !eppbp !ap|-2 !*) ;bp now -> last cons (outinst !staq !bp|2) ; rplacd the last cons (outinst !eppap !ap|-2))) ; and pop the pdl. (setq arg-height (- arg-height 2)) ; pops off 2 words, also. (remove result) result)))) (defun compfsubr (x y) ; compile a call to a system fsubr. (cond ((memq x '(comment declare)) (and (not effs) (make-const 'comment))) ((eq x 'cond) (compcond y)) ((eq x 'prog) (compprog y)) ((eq x 'setq) (compsetq y)) ((eq x 'go) (compgo (car y) (cadr y))) ((memq x '(and or)) (compandor (eq x 'or) y)) ((eq x 'signp) ((lambda (tag endtag) ; two temporaries. (outjump !tra endtag) ; t is in aq from code below. (define-tag tag) ; code for getting nil in aq. (get-in-aq (comp ''nil)) ; get nil in AQ. (define-tag endtag) ; code rejoins here. (setq AQ (ncons (gensym)))) ; and name the result; AQ-state kept by define-tag. (compred (cons x y) nil nil nil) ; cause it to be computed as a predicate. (prog2 (get-in-aq (comp ''t)) ; define label with t in the AQ previously. (level-tag nil))) ) ((eq x 'err) (comperr y)) ; compile an err, which may be compilable in-line. ((eq x 'errset) (comp-catches-and-errsets nil y)) ((eq x 'unwind-protect)(comp-catches-and-errsets 'unwind-protect y)) ((eq x 'catch) (comp-catches-and-errsets t y)) ((eq x 'throw) (compthrow y)) ((memq x '(store nstore)) (compstore y)) ((eq x 'iog) (compiog y)) ((eq x 'subrcall) (make-call (cons '*subr-ptr y) 'subr (cddr y))) ((eq x 'lsubrcall) (make-call (cons '*subr-ptr y) 'lsubr (cddr y))) ((eq x 'arraycall) (setq x (generate-array-reference (cons '*subr-ptr y) (cddr y))) (cond ((numberp x) ;in-line (storeaq?) ;about to load something into AQ (outwrd x) (setq AQ (ncons (gensym))) (putprop (car AQ) array-type 'number) (setq AQ-state (cdr (assq array-type '((fixnum . Q) (flonum . EAQ)(nil . nil))))) AQ) (t ;out of line x))) (t (make-call x 'fsubr y)))) (defun carinit () ; init car cdr optimizer (mapc '(lambda (x)(putprop (car x)(cdr x) 'carcdr)) carlist) (makunbound 'carlist)) (setq carlist '((symeval a) (car a)(cdr d) (caar a a) (cadr a d) (cdar d a) (cddr d d) (caaar a a a) (caadr a a d) (cadar a d a) (caddr a d d) (cdaar d a a) (cdadr d a d) (cddar d d a) (cdddr d d d) (caaaar a a a a) (caaadr a a a d) (caadar a a d a) (caaddr a a d d) (cadaar a d a a) (cadadr a d a d) (caddar a d d a) (cadddr a d d d) (cdaaar d a a a) (cdaadr d a a d) (cdadar d a d a) (cdaddr d a d d) (cddaar d d a a) (cddadr d d a d) (cdddar d d d a) (cddddr d d d d))) (carinit) ; init car cdr optimizer (defun reduce-cars (x y) ; x fun, y arglist (do ((clist (get x 'carcdr) (append clist z)) (y (car y)(cadr y)) (z)) (nil) (or (and (not (atom y)) (atom (car y)) (setq z (get (car y) 'carcdr)) (not (unsysp (car y)))) (return (cons clist(comp y))))))))))) (defun compcarcdr (x y) ; function which does car cdr compilations. (setq y (reduce-cars x y)) (setq x (car y) y (cdr y)) (clearaq) ; going to clobber AQ. (setq y (prog2 0 (iloc y) (remove y))) ; locate value in storage. remove from load list also. (and (eq (car y) 'special) ; if special, one extra instruction needed. (prog2 (outinst !eppbp y) (setq y !bp|0))) (cond ((and (null (cdr x))(eq (car x) 'a)) (outinstag !ldaq y !*)) ; car is trivial... (t (outinstag !eppbp y !*) (cond ((eq (car x) 'a) (outinstag !ldaq (carcdr (cdr x)) !*)) (t (outinst !ldaq (carcdr x)))))) (setq AQ (ncons (gensym)))) ;AQ-state set by clearaq above. (defun carcdr (x) (and (cdr x) (outinstag !eppbp (carcdr (cdr x)) !*)) (cond ((eq (car x) 'a) !bp|0) (t !bp|2))) ;; setq -- optimized cases as shown: ;; ;; (setq ... v 0 ...) -- stz ;; if v is fixnum var, _a_n_d v is not special (because type field may never have been set) ;; Also, the following RAR cases are recognized if ;; v is not in a register, and y is a constant or a variable: ;; (setq ... v (+ x 1) ...) -- aos ;; (setq ... v (+ x y) ...) -- asa or asq ;; (setq ... v (+ y x) ...) -- ditto ;; (setq ... v (- x y) ...) -- lcq, asq ;; (setq ... v (- y x) ...) -- ssq or ssa (defun compsetq (x) ; compile setq list (do ((xx x (cddr xx))) ((null xx) x) (setq x (do-setq (car xx) (cadr xx))))) (defun do-setq (v e) ; setq var v to expression e (cond ((and (not (atom e)) ; if expression (memq (car e) '(+ -)); with RAR function (cdr e) (cddr e) (null (cdddr e)) ; and exactly 2 args (or (eq v (cadr e)) (eq v (caddr e))) ; and var as an arg. (not (and (not (atom AQ)) (eq (car AQ) v)))) ; not in AQ already (do-rar-setq v (car e) (cadr e) (caddr e)) ; then do RAR (cons v cnt)) (t (setq e (comp e)) (cleanup-var-load v) (setq cnt (+ 2 cnt)) (cond ((in-bb e) (remove e) (storevalue-bb v)) ; store from bb ((and (eq (car e) 'quote) (eq (cadr e) 0) (not (specialp v)) (eq (get v 'number) 'fixnum)) ; stz into fixnum var (remove e) (outarith !stz (cond ((specialp v) (list 'special v)) (t (get-home v))))) (t (cond ((in-aq e) (remove e)) (t (get-in-aq e))) (storeaq?) (storevalue v) (setq AQ (cons v 'dup)))) ; duplicate value in AQ (setq null-var-list (delq v null-var-list 1)) (cons v cnt)))) ;; function to handle RAR setq's. (defun do-rar-setq (v op x y) ; (setq v (op x y)) (cond ((eq op '+) (and (eq v x) (setq x y))) ; x <- amount added ((eq v x) (setq x y)) ; x <- amount subtracted (t (setq op '-reversed))) (setq y (comp v) x (comp x)) ; order of computation doesn't matter (remove y) (cleanup-var-load v) (setq cnt (+ 2 cnt)) (setq null-var-list (delq v null-var-list 1)) (setq v (cond ((specialp v) (list 'special v)) (t (get-home v)))) ; v now has address ov var. (cond ((eq op '+) (cond ((and (eq (car x) 'quote) (eq (cadr x) '1)) (remove x) (outarith !aos v)) (t (get-fixnum x) (outarith (choose-opc !asa !asq) v)))) ((eq op '-) (clearaq) ; will put useless value in AQ. (outarith !lcq (ilocs x)) ; if x (quote n), won't allocate storage (remove x) (outarith !asq v)) ((eq op '-reversed) ; want to subtract value of v from x (get-fixnum x) (outarith (choose-opc !ssa !ssq) v)) (t (barf op "unknown RAR op" barf)))) ; auxiliary storage manipulation functions (defun storevalue (x) ; stores AQ into value cell of variable x. (cond ((specialp x) (put-type-in-aq) (outinstag !staq (make-const x) !*)) (t ((lambda (type) ; get type of local variable... (cond ((eq type 'fixnum) (cond ((eq AQ-state 'A) (outarith !sta (get-home x))) ((eq AQ-state 'Q) (outarith !stq (get-home x))) ((null AQ-state) (outarith !stq (get-home x))) (t (barf x "could no be assigned value of non-fixnum type" data)))) ((eq type 'flonum) (cond ((eq AQ-state 'EAQ) (outfloat !fst (get-home x))) ((null AQ-state) (outfloat !stq (get-home x))) (t (barf x "could not be assigned non-flonum value" data)))) (t (put-type-in-aq) (outinst !staq (get-home x))))) (get x 'number))))) (defun storevalue-bb (x) ; store the value of variable x from bb (cond ((specialp x) (outinstag !spribb (make-const x) !*)) (t (outinst !spribb (get-home x))))) (defun get-home (x) ; get home of local variable x. (do ((slot slotlist (cdr slot)) (tempi 0 (+ 2 tempi))) ((null slot) (barf x "has no home" barf)) ; error if no home! (and (not (atom (car slot))) ; slotlist element must be list, (eq (caar slot) x) ; and have x as car, (eq (cdar slot) 'home) ; and be the home of that var. (return (list 'temp (- tempi arg-height)))))) (defun compset (x y) (cleanup-special-var-loads) ; might be setting one of our current special vars. (comrplaca x y) y) (defun comrplaca (x y) ; store AQ indirect through location of x. (prog (which) ; holds instruction to use. (cond ((in-bb y) (remove y) (setq which !spribb)) (t (get-in-aq y) (setq which !staq))) (cond ((in-bb x) (outinst which !bb|0)) ; if address already available (t (setq y (ilocs x)) ; find x in storage. (cond ((eq (car y) 'special) ; if special value is to be stored through, (outinst !eppbp y) (setq y !bp|0))) ; store through bp. (outinstag which y !*))) (remove x) ; remove x from loadlist. (return x))) ; rplaca returns first arg. (defun comrplacd (x y) ; compile rplacd. (prog (which) ; holds instruction to use. (cond ((in-bb y) (remove y) (setq which !spribb)) (t (get-in-aq y) (setq which !staq))) (cond ((in-bb x) (outinst which !bb|2)) (t (setq y (ilocs x)) ; locate x in storage. (cond ((eq (car y) 'special) ; special value requires additional instruction. (outinst !eppbp y) (setq y !bp|0))) (outinstag !eppbp y !*) ; get pointer to cons. (outinst which !bp|2))) (remove x) ; remove the reference to x. (return x))) (defun compmemq (x y) (clearaq) ((lambda (tag1 tag2) (outinst !eppbp (iloc y)) ; get address of 2nd value in bp, (outinst !eppbp !bp|-2) ; and treat it as cdr of a "fake cons". (define-tag tag1) ; define loop tag. (outinst !ldaq !bp|2) ; check cdr of list for nil, before going down it. (outinst !cmpaq (make-const nil)) (outjump !tze tag2) (outinst !epplb !bp|0) ; remember whose car we are loading. (outinstag !eppbp !bp|2 !*) ; go down cdr of list. (outinst !ldaq !bp|0) ; load car of list. (outinst !cmpaq (iloc x)) ; cnd check for what is searched for. (outjump !tnz tag1) ; jump back to loop. (outinst !ldaq !lb|2) (remove x) ; remove references to first arg. (remove y) ; remove references to y on loadlist. (define-tag tag2) (setq AQ (ncons (gensym)))) ; return result, which is in AQ; AQ-state set by clearaq above. (level-tag nil) (level-tag nil))) (defun level-tag (tag) ; if nil, make a new tag...which can be gone to. (force-arg-height) ; make sure that arg-height is fixed up... (storeaq?) ; if aq must be stored, do it! (storebb?) (cond ((and tag (getl tag '(level))) (or (and (eq AQ (get tag 'AQ)) (eq AQ-state (get tag 'AQ-state))) ; if AQ the same as before, ok. (prog2 (remprop tag 'AQ) ; remove AQ, AQ-state properties... (remprop tag 'AQ-state))) ; effectively sets them to nil. (or (eq BB (get tag 'BB)) ; same thing in BB (remprop tag 'BB)) (do ((slot slotlist (cdr slot)) (slot1 (get tag 'level) (cdr slot1))) ((or (null slot1) (and (null slot) (rplacd slot1 nil)))) (or (eq (car slot1) (car slot)) (rplaca slot1 nil)) ; if not the same, forget possible result. )) (t (putprop (or tag (setq tag (gensym))) (append slotlist nil) 'level) ; save slotlist state. (and AQ-state (putprop tag AQ-state 'AQ-state)) ; save contents of AQ, AQ-state at this time. (and AQ (putprop tag AQ 'AQ)) (and BB (putprop tag BB 'BB)))) tag) (defun testnil (pred test tag) ; test out-of-line predicate, jump on test to tag. (get-in-aq (comp pred)) ; get pred value in aq. (outinst !cmpaq (setq pred (make-const nil))) ; compare with nil. (or test (setq AQ (prog2 (storeaq?) pred (setq pred AQ)))) ; if null test, (storeaq?) will be in AQ at jump target. (setq tag (level-tag tag)) ; merge state with that of tag... (outjump (cond (test !tnz) (t !tze)) tag) ; put out correct jump. (setq AQ pred) ; AQ gets nil if test was for t, else value saved in pred. tag) ; return (possibly newly made) tag. (defun compcond (cl) ; cl is of form: ((...setq-list...) save-special-flag (p1 ...) (p2 ...)) (clear-null-var-list) ; clear up all variables we have yet to bind to nil. ; if we knew some that weren't used yet, could avoid this somewhat. (and (cadr cl) (cleanup-special-var-loads)) ; if any calls, and such, cleanup the references to specials. (mapc 'cleanup-var-load (car cl)) ; get all references to variables that are setq'ed in the cond itself. (do ((cl (cddr cl) (cdr cl)) (endtag) (clv) (nxtag)) ((null (cdr cl)) ;special case last phrase. (progn ; damn do format! (cond ((cdar cl) ; if (pred value) form, (cond ((easygo (cadar cl)) (compred (caar cl) t nil (cadr (cadar cl))) (setq clv (comp0 ''nil))) (t (setq endtag (compred (caar cl) nil (null effs) endtag)) ; do predicate, jump if nil. (setq clv (comp0 (cadar cl)))))) ; get clause value. (t (setq clv (comp0 (caar cl))))) ; get predicate value for form (pred). (or effs (get-in-aq clv)) ; get the clause value in the AQ. (and endtag (define-tag endtag)) ; here is theplace where we go for the end. (setq cnt (+ 2 cnt)) (or AQ (setq AQ (ncons (gensym)))))) ; return AQ, if same value for all clauses, else new ; value description if AQ useless, and put in AQ. (cond ((cdar cl) ; (pred value) format (cond ((easygo (cadar cl)) (compred (caar cl) t nil (cadr (cadar cl)))) (t (setq nxtag (compred (caar cl) nil nil nil)) ; compile predicate. (setq clv (comp0 (cadar cl))) ; compile value. (or effs (get-in-aq clv)) (outjump !tra (setq endtag (level-tag endtag))) ; and put in a jump to the end of cond. (and nxtag (define-tag nxtag))))) ; and then define tag for next clause. (t (setq endtag (compred (caar cl) t (null effs) endtag)))))) ; if (pred) format, jump to end on t... (defun compandor (test cl) ; compile and or or for value or effect. (clear-null-var-list) (and (cadr cl) (cleanup-special-var-loads)) ; if possibitity of setqing specials, load now. (mapc 'cleanup-var-load (car cl)) ; load all variables to be setqed. (do ((cl (cddr cl) (cdr cl)) (tag nil) (load (null effs))) ((null (cdr cl)) (progn (setq load (comp0 (car cl))) ; compute last phrase. (or effs (get-in-aq load)) ; get in aq if for value. (and tag (define-tag tag)) ; put the end tag here. (setq cnt (+ 2 cnt)) (or AQ (setq AQ (ncons (gensym)))))) (setq tag (compred (car cl) test load tag)))) (defun clear-null-var-list () ; generates stores to all variables which are virtually bound to nil. (cond (null-var-list (get-in-aq (comp (make-const nil))) ; get nil into the AQ. (mapc '(lambda (x) (or (get x 'number) (storevalue x))) null-var-list) (setq null-var-list nil)))) ;;; *** is it right to not store at all when numeric??? *** (defun compred (pred test load tag) ; pred is the predicate to be compiled. ; test represents the value to be tested for, and jumped on. ; load=t forces value of pred to be in AQ when jump is done. ; tag=nil causes a new tag to be made, and returned by compred, ; else the specified tag is jumped to and returned as the value of compred. ((lambda (fn) (cond ((or (atom pred) ; if predicate is atom, or load is forced, or a non-system function call (not (atom (car pred))) ; then just compute value, load, and test for nil. (not (sysp (car pred)))) (testnil pred test tag)) ; compute and test predicate value. ((prog2 (setq fn (car pred)) ; fn gets the (atomic) function applied. (eq fn 'progn)) (do ((l (cdr pred) (cdr l))) ((null (cdr l)) (compred (car l) test load tag)) (compe (car l)))) ; compute each clause for effect, except last. ((and (eq fn 'prog2) (null (cdddr pred))) (compe (cadr pred)) (compred (caddr pred) test load tag)) ; special case of prog2. ((eq fn 'quote) (setq fn (comp pred)) ; compute the predicate. (cond ((eq (not test) (not (cadr fn))) ; if testing for the value computed, do jump. (cond (load (get-in-aq fn)) ; if load, load it, else (t (remove fn))) ; remove it, (outjump !tra (setq tag (level-tag tag)))) ; and jump. (t (remove fn))) ; remove value from loadlist. tag) ((memq fn '(= < >)) ; comparison functions of restricted domain. (comp-parison (comp (cadr pred)) (comp (caddr pred)) fn test load tag)) ((eq fn 'memq) ; memq compilable in-line, always loads AQ with predicate value. (setq fn (comp (cadr pred))) ; compile args. (setq pred (comp (caddr pred))) (clearaq) (outinst !eppbp (iloc pred)) ; get address of second val in bp, (outinst !eppbp !bp|-2) ; make believe it is a cons ((lambda (ltag) (define-tag ltag) ; output loop tag, remembering it. (outinst !ldaq !bp|2) ; load the cdr of the current cons. (outinst !cmpaq (setq AQ (make-const nil))) (outjump !tze ; jump if nil to: (cond (test (setq test (level-tag nil))) ; if testing for t, after memq. (t (setq tag (level-tag tag))))) ; else, to the tag we are to jump on nil to. (and test load (outinst !epplb !bp|0)) ; if test is t and want to load, save thing to load. (outinstag !eppbp !bp|2 !*); move down cdr of list. (outinst !ldaq !bp|0) ; check car of list to see if it is the right thing. (outinst !cmpaq (iloc fn)) ; by comparing with the value we had before gotten. (outjump !tnz ltag) ; if not eq, then loop back. (setq AQ fn)) (level-tag nil)) ; get new tag for ltag. (cond (test ; if testing for t, (and load (progn (outinst !ldaq !lb|2) (setq AQ nil))) (outjump !tra (setq tag (level-tag tag))) (define-tag test))) ; define the tag for nil. (remove pred) ; remove references to second val on loadlist. (remove fn) tag) (load (cond ((memq fn '(null eq zerop minusp plusp signp fixp smallnump floatp numberp bigp atom stringp subrp arrayp definedp boundp filep symbolp)) (setq fn (compred pred (not test) nil nil)) (setq pred (comp (cond (test ''t) (t ''nil)))) (get-in-aq pred) (outjump !tra (setq tag (level-tag tag))) (define-tag fn) tag) (t (testnil pred test tag)))) ; could do and, or, cond better than this will do. ((eq fn 'null) (compred (cadr pred) (not test) nil tag)) ; for null, just invert the test. ((eq fn 'eq) (setq fn (comp (cadr pred))) (setq pred (comp (caddr pred))) ; both values are thus computed. (cond ((in-aq fn) (put-type-in-aq) (outinst !cmpaq (ilocs pred)) (remove fn) (remove pred)) ((in-aq pred) (put-type-in-aq) (outinst !cmpaq (ilocs fn)) (remove fn) (remove pred)) ((and (not (atom (cdr fn))) (eq (car fn) 'quote)) ; if fn is constant, (get-in-aq pred) (outinst !cmpaq (ilocs fn)) (remove fn)) (t (get-in-aq fn) (outinst !cmpaq (ilocs pred)) (remove pred))) (cond ((and (not (atom (cdr fn))) (eq (car fn) 'quote)) ; fn is a constant, so make AQ that. (setq load fn)) ((and (not (atom (cdr pred))) (eq (car pred) 'quote)) ; pred is a constant. (setq load pred)) (t (setq load AQ))) (and test (setq AQ (prog2 (storeaq?) load (setq load AQ)))) (outjump (cond (test !tze) (t !tnz)) (setq tag (level-tag tag))) (setq AQ load) tag) ((eq fn 'fixp) (comp-type-test (cadr pred) (logor !fixtype !bigtype) test tag)) ((eq fn 'smallnump) (comp-type-test (cadr pred) !fixtype test tag)) ((eq fn 'bigp) (comp-type-test (cadr pred) !bigtype test tag)) ((eq fn 'floatp) (comp-type-test (cadr pred) !flotype test tag)) ((eq fn 'numberp) (comp-type-test (cadr pred) !numtype test tag)) ((eq fn 'atom) (comp-type-test (cadr pred) !atomtype test tag)) ((eq fn 'filep) (comp-type-test (cadr pred) !filetype test tag)) ((eq fn 'symbolp) (comp-type-test (cadr pred) !atsymtype test tag)) ((eq fn 'stringp) (comp-type-test (cadr pred) !strtype test tag)) ((eq fn 'subrp) (comp-type-test (cadr pred) !subrtype test tag)) ((eq fn 'arrayp)(comp-type-test (cadr pred) !arraytype test tag)) ((eq fn 'zerop) (or (try-comparative-and (cadr pred) test tag) (test-sign (comp (cadr pred)) (cond (test 'n) (t 'e)) tag))) ((eq fn 'minusp) (test-sign (comp (cadr pred)) (cond (test 'ge) (t 'l)) tag)) ((eq fn 'plusp) (test-sign (comp (cadr pred)) (cond (test 'le) (t 'g)) tag)) ((eq fn 'signp) ; generalized sign testing operator... (setq fn (comp (caddr pred))) ; get value of arg. (setq pred (cadr pred)) (cond (test (setq pred (cdr (assq pred '((l . ge) (ge . l) (n . e) (e . n) (le . g) (g . le))))))) (cond ((or (known-fixnum fn) (known-flonum fn)) (test-sign fn pred tag)) ; do special fast test, since is a number. (t (get-in-aq fn) ; must compute the value to be tested. (outinstag !cana !numtype !dl) ; check for number. (setq fn nil) (cond (test (outjump !tze (setq fn (level-tag fn)))) ; if not number jump to end. (t (outjump !tze (setq tag (level-tag tag))))) ; if testing for nil, jump to lab if not num. (outinstag !tspbp !ab|signp !*) ; get the indicators set, regardless of type. (outjump (cdr (assq pred !jump-tests)) (setq tag (level-tag tag))) (and fn (define-tag fn)) tag))) ((memq fn '(boundp definedp)) (clearaq) (setq fn (comp (cadr pred))) (setq pred (ilocs fn)) (cond ((eq (car pred) 'special) (outinstag !eppbp (make-const (cadr pred)) !*) (setq pred !bp|0))) (outinstag !ldaq pred !*) (outjump (cond (test !tnz) (t !tze)) (setq tag (level-tag tag))) (remove fn) tag) ((eq fn 'and) (and (caddr pred) (cleanup-special-var-loads)) (mapc 'cleanup-var-load (cadr pred)) (clear-null-var-list) (do ((clause (cdddr pred) (cdr clause)) (niltag (cond (test nil) (t tag)))) ; if testing for t, get tag later. ((null (cdr clause)) ; last clause treated special. (progn (cond (test (setq tag (compred (car clause) t nil tag)) (and niltag (define-tag niltag))) ; if niltag created, define it. (t (setq tag (compred (car clause) nil nil niltag)))) (setq cnt (+ 2 cnt)) tag)) (setq niltag (compred (car clause) nil nil niltag)))) ; compile all other preds, test for nil. ((eq fn 'or) (and (caddr pred) (cleanup-special-var-loads)) (mapc 'cleanup-var-load (cadr pred)) (clear-null-var-list) (do ((clause (cdddr pred) (cdr clause)) (niltag (cond (test tag) (t nil)))) ; if testing for nil, get tag later. ((null (cdr clause)) ; last clause specially treated. (progn (cond (test (setq tag (compred (car clause) t nil niltag))) (t (setq tag (compred (car clause) nil nil tag)) (and niltag (define-tag niltag)))) (setq cnt (+ 2 cnt)) tag)) (setq niltag (compred (car clause) t nil niltag)))) ((eq fn 'cond) ; cond as a predicate can be distributed! (and (caddr pred) (cleanup-special-var-loads)) (mapc 'cleanup-var-load (cadr pred)) (clear-null-var-list) (do ((cl (cdddr pred) (cdr cl)) (nxtag) (endtag)) ((null (cdr cl)) (progn (cond ((cdar cl) ; two element clause. (cond (test (setq endtag (compred (caar cl) nil nil endtag))) ; if testing for t, jump to end of cond on nil. (t (setq tag (compred (caar cl) nil nil tag)))) ; otherwise, if predicate nil, jump to tag. (setq tag (compred (cadar cl) test nil tag))) (t (setq tag (compred (caar cl) test nil tag)))) (and endtag (define-tag endtag)) (setq cnt (+ 2 cnt)) tag)) (cond ((cdar cl) ; cond with two parts. (setq nxtag (compred (caar cl) nil nil nil)) (setq tag (compred (cadar cl) test nil tag)) ; compile body of clause for jump. (outjump !tra (setq endtag (level-tag endtag))) ; jump to end of cond. (define-tag nxtag)) (test (setq tag (compred (caar cl) test nil tag))) ; if for t, and pred is thus for both. (t (setq endtag (compred (caar cl) t nil endtag)))))) ; if for nil, jump on t to end of this. (t (testnil pred test tag)))) ; if not, give up, and force evaluation for value.! nil)) (defun comp-type-test (val bits test tag) ; compute a test for type. (get-in-aq (comp val)) (outinstag !cana bits !dl) (outjump (cond (test !tnz) (t !tze)) (setq tag (level-tag tag))) tag) (declare (eval (read))) (setm comparison-tests ((= 600000 601000 600000 601000) (< 604000 605000 605400 604400) (> 605400 604400 604000 605000))) ; used by comp-parison to jump on indicators. (defun known-fixnum (val) (cond ((eq (car val) 'quote) (smallnump (cadr val))) ((eq 'fixnum (get (car val) 'number))))) (defun known-flonum (val) (cond ((eq (car val) 'quote) (floatp (cadr val))) ((eq 'flonum (get (car val) 'number))))) (defun comp-parison (val1 val2 fn test load tag) ; compile a compare function. jump on result = ((lambda (jumps) ;test to tag. (cond ((or (known-fixnum val1) (known-fixnum val2)) (cond ((in-aq val1) (remove val1)) ((in-aq val2) (remove val2) (setq jumps (cddr jumps)) (setq val2 val1)) ((eq (car val1) 'quote) (get-fixnum val2) (setq jumps (cddr jumps)) (setq val2 val1)) (t (get-fixnum val1))) (setq val1 (ilocs val2)) (cond ((eq AQ-state 'A) (outarith !cmpa val1)) (t (outarith !cmpq val1)))) ((or (known-flonum val1) (known-flonum val2)) (cond ((and (in-aq val1) (or (eq AQ-state 'EAQ) (eq fn '=))) (remove val1)) ; val1 in aq ok! ((and (in-aq val2) (or (eq AQ-state 'EAQ) (eq fn '=))) (remove val2) (setq jumps (cddr jumps)) (setq val2 val1)) ((eq (car val1) 'quote) (get-flonum val2) (setq jumps (cddr jumps)) (setq val2 val1)) (t (get-flonum val1))) (setq val1 (ilocs val2)) (cond ((eq AQ-state 'EAQ) (outfloat !fcmp val1)) (t (outfloat !cmpq val1)))) (t (cond ((in-aq val1) (remove val1)) ((in-aq val2) (remove val2) (setq jumps (cddr jumps)) (setq val2 val1)) ((eq (car val1) 'quote) (get-in-aq val2) (setq jumps (cddr jumps)) (setq val2 val1)) (t (get-in-aq val1))) (setq val1 (ilocs val2)) (cond ((eq fn '=) (outfloat !cmpq val1)) ; don't have to use op in = case. (t (clearbb) ; we are going to use bb. (outinst !eppbb val1) ; get pointer to other operand. (outinstag !tspbp !ab|compare !*))))) (remove val2) (outjump (cond (load (outjump (cond (test (cadr jumps)) ; must get loaded result in AQ. (t (car jumps))) (setq jumps (level-tag nil))) ; jump to end of pred if not jumping (get-in-aq (comp (make-const test))) ; get value in aq !tra) (test (car jumps)) (t (cadr jumps))) (setq tag (level-tag tag))) (and load (define-tag jumps)) tag) (cdr (assq fn !comparison-tests)))) (defun test-sign (value condition tag) ((lambda (type endtag oldcodelist) ;; test sign of known numeric value of type type, ;; jump if condition (g, ge, l, le, e, n) not true to atag. ;; endtag is used by zerop test, to get to end of code. (cond ((eq type 'fixnum) (get-fixnum value) (cond ((eq AQ-state 'A) (outarith !cmpa (make-const 0))) ((and (eq AQ-state 'Q) (not (eq codelist oldcodelist)))) ;already loaded (t (outarith !cmpq (make-const 0))))) ((eq type 'flonum) (get-flonum value) (outfloat !fcmp (make-const 0.0))) (t (get-in-aq value) ; get typed value (cond ((eq condition 'e) ; these two cases don't need all indicators set. (outinst !cmpaq (make-const 0)) (outjump !tze (setq endtag (level-tag nil))) ; jump to end of zerop test if zero. (outinst !cmpaq (make-const 0.0))) ((eq condition 'n) (outinst !cmpaq (make-const 0)) (outjump !tze (setq tag (level-tag tag))) (outinst !cmpaq (make-const 0.0))) (t (outinstag !tspbp !ab|signp !*))) )) (outjump (cdr (assq condition !jump-tests)) (setq tag (level-tag tag))) (and endtag (define-tag endtag)) ; if we used endtag, define it. tag) (cond ((known-fixnum value) 'fixnum) ; this might be done more efficiently sometime. ((known-flonum value) 'flonum) (t nil)) nil codelist)) (defun try-comparative-and (pred test tag) ; special case (zerop (logand x const)) (and (not (atom pred)) ; pred must be (boole 1 xxx.. ) (eq (car pred) 'boole) (not (unsysp 'boole)) (not (atom (cadr pred))) (eq (caadr pred) 'quote) ; must be constant boolectl (= (cadadr pred) 1) ; better be a # at this point ((lambda (x y) ;compile operands (cond ((eq (car x) 'quote) ;let y be the constant, if any (setq x (prog2 0 y (setq y x))))) (cond ((in-aq y)(setq y (prog2 0 x (setq x y))))) (get-fixnum x) (outarith (choose-opc !cana !canq) (iloc y)) (remove y) ; finished using y ; x remains in AQ (outjump (cdr (assq (cond (test 'n)('e)) !jump-tests)) (setq tag (level-tag tag))) tag) ;return the tag (comp (caddr pred)) (comp (cadddr pred))))) (defun comp-catches-and-errsets (catch? y) ((lambda (tag name offset cont-tag result) (cleanup-var-loads) ; so errors causing random jumps don't foul us up... (clear-null-var-list) ; since we expect random jumps, make sure all vars correctly bound. (storeaq?) ; make sure aq value is stored... (clearbb) (cond ((eq catch? 'unwind-protect) (force-arg-height)) ((cdr y) (setq bump-arg-height (+ bump-arg-height 2)) (setq name (comp (cadr y))) ; note: (catch ... tag) -> (catch ... 'tag) in pass 1. (get-in-aq name) ; if tag were nil for errset, pass1 would have dleted it. (storearg -2)) ; and push it on stack. (t ; catch or errset with only one arg... (force-arg-height) ; make sure arg-height is bumped here. (setq arg-height (+ arg-height 2)))) ; operator pushes 2 words on marked pdl. (setq AQ nil AQ-state nil) ;AQ known to contain nothing good - make it nil since ((lambda (slotlist) ; catch/errset operator will soon mung it. (setq tag (level-tag nil))) ;make a tag with a cleared-up slotlist and AQ. (clearslotlist)) (setq framel (cons (list (cond ((eq catch? 'unwind-protect) unwptag) ((null catch?) errtag) (t name)) arg-height ; must pop off to this location if unwinding through this. tag) framel)) ; push note of this frame onto framel. (outinstag !tspbp (cond ((cdr y) (+ offset 2000000)) (offset)) !*) ; output a call to the correct operator. (outinst !tra tag) ; skipped by operator set up. ; NOTE: this tra is done by outinst, because outjump would cause ; any code following this to be supressed. (setq result (comp0 (car y))) ; Compute the first arg. (cond ((eq catch? 'unwind-protect) ; lotta stuff to do. (clearaq) (clearbb) (cond ((and useless-code (not labels-to-define))(setq cont-tag nil)) ;set flag for no stuff (t ((lambda (slotlist) (setq cont-tag (level-tag nil))) ; make tag for end. (clearslotlist)) (outinstag !tspbp (+ offset 4000000) !*) ;ununwp op (outjump !tra cont-tag))) (define-tag tag) ; This is the handler. (mapc 'compe (cdr y)) ; Compile the handler. (outjumptag !tra !ab|irest-return !*) ; Return via Lisp, restoring interrupt system. (and cont-tag (define-tag cont-tag)) ; The continuation (setq framel (cdr framel)) (or effs (remove result)) result) (t (or effs (get-in-aq result)) (define-tag tag) ; put the tag here... (outinstag !tspbp (+ offset 4000000) !*) ; undo the frame. (setq arg-height (- arg-height 2)) ; operator pops this much. (setq framel (cdr framel)) (setq AQ (ncons (gensym)))))) ; return new name, put in AQ too. ; AQ-state maintained by get-in-aq nil catchtag (cond ((eq catch? 'unwind-protect) !ab|unwp1)(catch? !ab|catch1) (t !ab|errset1)) nil nil)) (defun unwind (tag) ; general unwinder of frames, for throw, err, and go. (do ((frame framel (cdr frame))) ((eq (caar frame) tag) ; if at the place we wanted... (progn (popap (cadar frame)) ; pop the ap back to the desired arg-height. (cddar frame))) ; return the rest of the info in the frame list entry. (unwind-one-frame (car frame)))) (defun unwind-one-frame (frame) (cond ((eq (car frame) progtag)) ; if it is a progtag, but not what we are looking for, ignore. ((prog2 (popap (cadr frame)) ; all frames have height to be popped to here. (eq (car frame) bindtag)) ; check for binding frame to be removed. (clearbb) (outinstag !tspbp !ab|unbind !*) (setq arg-height (caddr frame))) ; ap gets popped by unbind operator. ((eq (car frame) errtag) ; must undo an errset. (clearbb) (setq arg-height (- arg-height 2)) ; operator pops off 2 words. (outinstag !tspbp !ab|unerrset !*)) ; call the unerrset operator. ((eq (car frame) unwptag) ; unwind protect (clearbb) (outinstag !tspbp !ab|ununwp !*)) ; Make like finished executing (t (clearbb) (setq arg-height (- arg-height 2)) ; operator pops off 2 words. (outinstag !tspbp !ab|uncatch !*)))) ; uncatch operator. (defun popap (height) (cond ((= arg-height height)) (t (outinst !eppap (logor !ap| (left (logand 77777 (- height arg-height))))) (setq arg-height height)))) (defun compthrow (y) ; compute a throw, trying to do it inline if possible... ((lambda (tag arg-height) (cond ((cdr y) (setq tag (get-const (cadr y))))) ; if named throw, get name of tag thrown to. (setq y (comp (car y))) ; compute value thrown. (cond ((do ((frame framel (cdr frame))) ((null frame) nil) (cond ((eq (caar frame) catchtag) (setq tag catchtag) (return t)) ((eq (caar frame) tag) (return t)))) (setq tag (car (unwind tag))) ; unwind the frames above the catch. (get-in-aq y) ; make sure the value is in the AQ. (outjump !tra tag)) ; finally, jump to the uncatch tag for that catch. (t (get-in-aq y) ; get value in the AQ. (cond ((eq tag catchtag) ; if no-name throw, then use throw op 1. (outinstag !tra !ab|throw1 !*)) (t ; put value on top of stack. (setq bump-arg-height (+ 4 bump-arg-height)) (storearg -2) ; store it on top of the stack. (setq loadlist (cons tag loadlist)) (get-in-aq tag) ; get the tag to thorw to in aq. (outinstag !tra !ab|throw2 !*) (setq arg-height (- arg-height 4)))) ; too bad it doesn't return...but keep things consistent. (setq useless-code t))) ; mask code through the next label. (setq AQ-state nil AQ (ncons (gensym)))) ; return a dummy name for this quantity. catchtag arg-height)) (defun comperr (y) (setq y (comp (car y))) ; compute the value err'd with. ((lambda (tag arg-height) ; working storage...rebind arg-height for unwind (cond ((assq tag framel) ; check for in-line err signal if possible. (setq tag (car (unwind tag))) ; unwind stack...retrns label to jump to to finish off stuff. (get-in-aq y) ; do the jump with aq loaded. (outjump !tra tag)) (t (get-in-aq y) ; set up for err-op call. (outinstag !tra !ab|err !*) ; jump to err op. (setq useless-code t))) ; ignore code to next label. (setq AQ-state nil AQ (ncons (gensym)))) errtag arg-height)) (defun compreturn (x nlevels) ; compile a return from a prog. ((lambda (effs arg-height) ; evaluate argument in prog state of effs... (setq x (comp0 x)) ; compute argument. (unwindgoret nlevels) ; unwind to the specified prog level (or effs (get-in-aq x)) ; get the value returned into the AQ, if needed. (setq x (find-nth exit nlevels)) ; find the exit from the particular prog. (outjump !tra (car (rplaca x (level-tag (car x))))) ;and output a jump to it. (setq AQ-state nil AQ (ncons (gensym)))) ; return a dummy name, and fool compiler into thinking its in AQ. (car (find-nth prog-for-effs nlevels)) arg-height)) (defun compgo (x nlevels) ; compile a goto. ((lambda (arg-height) ; rebind arg-height for unwinding operation. (cond ((atom x) ; normal case. (clear-null-var-list) (unwindgoret nlevels) ; pop back to specified prog level (outjump !tra (level-tag x))) (t ; computed goto. (setq x (comp x)) ; so compute label to go to. (clear-null-var-list) (unwindgoret nlevels) ; pop back to specified prog level (get-in-aq x) ; get tag name in AQ, so computed go subroutine will work. (setq x (find-nth vgol nlevels)) ;find appropriate level in vgol pushdown list (outjump !tra (car (rplaca x (level-tag (car x))))))) ; jump to computed goto subroutine for the current prog. (setq AQ-state nil AQ (ncons (gensym)))) arg-height)) (defun find-nth (x nlevels) (cond ((zerop nlevels) x) ((find-nth (cdr x) (1- nlevels))))) (defun unwindgoret (nlevels) ;version of unwind which unwinds n+1 progtags (do frame framel (cdr frame) (minusp nlevels) (cond ((eq (caar frame) progtag) ;if a prog tag (setq nlevels (1- nlevels)))) ;count the progs (cond ((minusp nlevels)(popap (cadar frame)))) (unwind-one-frame (car frame)))) (defun easygo (x) ; see if value part of cond phrase is an easily done goto. (and (not (atom x)) ; must be form (eq (car x) 'go) ; with function go... (atom (cadr x)) ; with constant label. (= 0 (caddr x)) ; the level must be top-level (eq (caar framel) progtag) (= arg-height (cadar framel)) ; also, no arguments to be popped (= 0 bump-arg-height) ;no subtle hidden args, either (null null-var-list))) ; and no uninitialized variables... (defun compiog (y) ; compile a call to iog, which is an fsubr. (force-arg-height) ; force ap to be in the right place. (clearaq) ; iog bind operator clobbers AQ. (clearbb) (outinstag !tspbp !ab|iogbind !*) ; rebind all iog vars. (setq framel (cons (list bindtag (+ arg-height 16.) arg-height) framel)) (setq arg-height (+ arg-height 16.)) (cond ((car y) (compe (list 'ioc (car y))))) (setq y (comp0 (cadr y))) (clearbb) (outinstag !tspbp !ab|unbind !*) ; unbind. (setq arg-height (- arg-height 16.)) ; size of binding block. (setq framel (cdr framel)) (and (not effs) (remove y)) ; if we added it to loadlist, must delete it so only one copy gets there... y) ;;; array stuff (defun generate-array-reference (array subs) (prog (ndims type temp dimensions hack in-x0 array-ptr-name result) (cond ((atom array) (cond ((setq dimensions (get array 'array*)) (setq ndims (length dimensions) type (car (get array 'numfun))) (or (= ndims (length subs)) (barf (cons array subs) "wrong number of subscripts on array." 'data)) (setq temp (make-array-link array type ndims))) (t ;not declared array* (return (make-array-call array subs))))) ((eq (car array) '*subr-ptr) ;arraycall (setq ndims (length subs) type (cadr array)) (or (eq type 'fixnum) (eq type 'flonum) (setq type nil)) (setq temp (comp (caddr array))) ) (t (return (make-array-call array subs)))) (setq subs (mapcar 'comp subs)) ;find all the subscripts (clearbb) (cond ((atom array) ;pick up array-pointer (outinst !xec temp)) (t (setq temp (prog2 nil (ilocs temp) (remove temp))) (outinstag !eppbb temp !*) (and (eq (car temp) 'special) ;indirection didn't take... (outwrd !eppbb-bb*)))) (setq array-ptr-name (ncons (gensym)) BB array-ptr-name loadlist (cons BB loadlist)) ;make sure BB stays loaded. (and dimensions (not (memq nil dimensions)) (setq hack t)) (and (= ndims 1) (setq hack t)) ;never need multipliers in this case. (or hack (outinstag !eppbb !bb|2 !*)) ;-> array data. (cond ((and type (= ndims 1) (not (in-Q (car subs)))) ;can just lxl0 subscript (setq in-x0 t) (outarith !lxl0 (ilocs (car subs))) (remove (car subs))) ;; *** should do constant subscripts here (t ;compute subscript in q (do ((sub) (mpy nil) (first t nil)) ((null subs)) (setq sub (car subs) subs (cdr subs)) (and dimensions (setq dimensions (cdr dimensions) mpy (car dimensions))) (cond (first (get-fixnum sub) (cond ((eq AQ-state 'A) (outinst !lrl (left 36.)) (setq AQ-state 'Q))) ) (t (and result (remove result)) (storeaq?) (setq result (ncons (gensym)) AQ result AQ-state 'Q) (putprop result 'fixnum 'number) (setq loadlist (cons result loadlist)) (outarith !adq (ilocs sub)) (remove sub))) (or (and (null subs) type) ;going to clobber AQ? (progn ;yes, make new result. (and result (remove result)) (storeaq?) (setq result (ncons (gensym)) AQ result AQ-state 'Q) (putprop result 'fixnum 'number) (setq loadlist (cons result loadlist)) )) (cond ((null subs) ;last, maybe omit multiply (or type (outinst !qls (left 1)))) (mpy ;constant multiplier (do ((z 1 (lsh z 1)) (n 0 (1+ n))) (nil) (cond ((= z mpy) ;power of two. (return (or (zerop n) (outinst !qls (left n))))) ((> n 12.) ;not power of 2 I guess. (return (outinstag !mpy (left mpy) !dl)))))) ((outinst !mpy (- !bb|-1 (lsh (length subs) 19.))))) (or (eq BB array-ptr-name) (barf nil "some villain made off with my BB register!" barf)) ))) (and result (remove result)) ;now we know nothing will happen until BB and Q are picked up by caller (remove BB) (setq BB nil) (setq array-type type) ;pass type out to caller. (ecch) (return (logor ;return the instruction to load from array. (cond ((eq type 'fixnum) !ldq) ((eq type 'flonum) !fld) (t !ldaq)) (cond ((not hack) !bb|0) (t (logor !bb|2 60))) ;indirect postindex (cond (in-x0 !x0) (t !ql)) )))) (defun make-array-call (array subs) (cond ((getl array '(array *array)) (make-call array 'subr subs)) ;array is functional property ((or (specialp array) (memq array bvars)) (make-call (comp array) 'subr subs)) ;array is computed value (t (warn (cons array subs) "questionable array reference") (compform array subs)) )) ;hope for the best (defun comparray (array subs) ((lambda (how) (cond ((numberp how) ;in-line array reference (storeaq?) ;about to load something into AQ (outwrd how) ;code to load from array (setq AQ (ncons (gensym))) (putprop (car AQ) array-type 'number) (setq AQ-state (cdr (assq array-type ;make AQ-state more realistic '((fixnum . Q) (flonum . EAQ) (nil . nil))))) AQ) (t how))) ;out of line - return the result of make-call (generate-array-reference array subs) )) (defun compstore (y) (prog (type val addressibility) (setq val (comp (cadr y))) ;compute second operand first (setq y (cond ((eq (caar y) 'arraycall) (generate-array-reference (cons '*subr-ptr (cdar y)) (cdddar y))) ((generate-array-reference (caar y) (cdar y))))) (cond ((numberp y) ;inline, pick up ptr to where to store (setq addressibility (logand y !address-part)) (cond ((= (logand y !xrfield) !ql) ;ql modifier-- (outinst !eppbb addressibility) (setq addressibility !bb|0))) ;evaluate before changing Q. (setq type array-type) ;inline, store through bb (outinst (cond ((null type) (get-in-aq val) !staq) ((eq type 'fixnum) (get-fixnum val) (cond ((eq AQ-state 'A) !sta) (t !stq))) (t ;flonum (get-flonum val) (cond ((eq AQ-state 'EAQ) !fst) (t !stq))) ) addressibility)) ((and (in-aq val) (eq AQ-state 'EAQ)) ;out of line, floating. (outinstag !tspbp !ab|float-store-op !*) (remove val)) (t (get-in-aq val) (outinstag !tspbp !ab|store-op !*))) ;out of line, use opr. (return val))) (defun make-array-link (array type ndims) (get-function (make-const array) type 'array ndims)) ;; code to handle internal lambda-applications. ;; uses special null-var-list hack. (defun complambda (x y) ; first arg is functional form, second list of value names. (prog (ll bind-size slotx obvars locals speclist) (setq ll (cadr x) ; get lambda list, x (caddr x) ; body of lambda form, bind-size 0 ; space taken by special binding block obvars bvars) ; and save bvars list value at this time. (mapc '(lambda (var val) ; map over lambda list and corresponding values. (setq val (comp val)) ; compute the next value. (cond ((specialp var) (setq speclist (cons (list var val) speclist))) ; remember value to be bound in var. ; save location of value assigned, and value to be removed with var. (t (findtemp (get var 'number)) ; set slotx to point at a free temporary (of correct type) in slotlist (setq locals (cons (car (rplaca slotx (cons var 'home))) locals)) ; and put var's home here, also remembering how to remove it. (cond ((eq val (make-const nil)) ; if nil is to be the bound value, defer binding. (remove val) ; act as if we assigned value. (setq null-var-list (cons var null-var-list))) ((in-bb val) (remove val) (storevalue-bb var)) ((and (eq (car val) 'quote) (eq (cadr val) 0) (eq (get var 'number) 'fixnum)) ; stz into fixnum var. (remove val) (outarith !stz (get-home var))) (t (cond ((in-aq val) (remove val)) (t (get-in-aq val))) (storevalue var) (storeaq?) ; I am not sure this is necessary, but will never hurt code. (setq AQ (cons var 'dup)))))) ; remember what value is in AQ. ; AQ-state set by get-in-aq (setq bvars (cons var bvars))) ll y) (cond (speclist ; if specials to be bound, make a binding block. (force-arg-height) (mapc '(lambda (val) (cleanup-var-load (car val)) (setq bind-size (+ bind-size 4)) (rplacd val (cons (ilocs (cadr val)) (cdr val)))); locate value somewhere in storage. speclist) (clearaq) ; since bind op clobbers AQ. (clearbb) (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)) ; word saying how much space to reserve. (setq arg-height (+ bind-size arg-height)) (mapc '(lambda (val) ; map over speclist. (cond ((eq (caadr val) 'temp) ; if temp, must modify address since specbind addresses ; from the stack height after growing... (rplaca (cdadr val) (- (cadadr val) bind-size)))) (outbindwrd (make-const (car val)) (cadr val)) (remove (caddr val))) ; remove value from load list. speclist) (setq framel (cons (list bindtag arg-height (- arg-height bind-size)) framel)))) ; add a binding frame to unwind list. (setq cnt (1+ cnt)) (setq x (comp0 x)) ; compute value desired of body. ;; handle case where x is a variable. generate a new name, and make sure it is loaded, and on the loadlist. (cond ((and x (numberp (cdr x))) (get-in-aq x) (storeaq?) (setq x (ncons (gensym)) AQ x loadlist (cons x loadlist)))) (cond (speclist (clearbb) (outinstag !tspbp !ab|unbind !*) ; call the unbinder. (setq arg-height (- arg-height bind-size)) (setq framel (cdr framel)))) ;note unbinder must preserve AQ since the result is currently in it. (mapc '(lambda (x) ; map over all locals. (setq null-var-list (delq (car x) null-var-list)) ; if var was bound to nil, never used, this fixes it. (do slot slotlist (cdr slot) (null slot) ; flush variable home. (cond ((eq x (car slot)) (rplaca slot nil) (return nil))))) locals) (and x (remove x)) (setq bvars obvars) ; pop back bvars list. (return x))) ; return computed value. ;; code to implement the prog function. ;; basically similar to the lambda application stuff, ;; but handles labels, and especially the back reference cases. (defun compprog (y) ; argument is the list comprising the prog body. ((lambda (vgol exit) (prog (bindword locals slotx bind-size obvars) (setq obvars bvars ; remember the old bvars list. prog-for-effs (cons effs prog-for-effs)) ; remember what effs is for return's to this prog. (and (cadr y) (cleanup-special-var-loads)) ; if calls-out present, cleanup all references to specials. (mapc 'cleanup-var-load (car y)) ; assume any special vars in the prog var list are here. (setq y (cddr y)) (mapc '(lambda (x) ; map over all vars to be bound. (cond ((specialp x) ; if special variable, (cond ((null bindword) (force-arg-height) (clearaq) ; binding operator clobbers AQ. (clearbb) (outinstag !tspbp !ab|bind !*) (outwrd 000000) ;place holder for binding block size (setq bindword codelist) ;KLUDGE - remember patch loc (setq bind-size 0))) (setq bind-size (+ bind-size 4)) ; four more words pushed on stack. (outbindwrd (make-const x) (make-const nil))) (t (findtemp (get x 'number)) ; gets free temp, slotx points at slot. not bound to nil in case of number. (setq null-var-list (cons x null-var-list)) (setq locals (cons (car (rplaca slotx (cons x 'home))) locals)))) (setq bvars (cons x bvars))) (cadr y)) (cond (bindword (setq framel (cons (list bindtag (+ bind-size arg-height) arg-height) framel) arg-height (+ bind-size arg-height)) (rplaca bindword (left bind-size)))) (force-arg-height) (setq framel (cons (list progtag arg-height effs) framel)) (setq cnt (1+ cnt)) (cond ((car y) ; if tags... (storeaq?) (storebb?) ; clear slotlist must have these stored! ((lambda (sl) (mapc '(lambda (x) (setq x (cdr x)) ; go list is list of pairs. (cond ((get x 'back-reference) (putprop x (append sl nil) 'level) ))) ; AQ-state, AQ properties nil by virtue of non-existence. (car y))) (clearslotlist)))) (mapc '(lambda (x) ; map over all prog body elements. (setq cnt (1+ cnt)) ; just for kicks. (cond ((atom x) ; if a label, (clear-null-var-list) ; if any vars not yet set to nil, do so. (define-tag x)) ; and make this label a tag. (t (compe x)))) (cddr y)) (cond ((car vgol) ; if variable go feature used, (cond ((not useless-code) (compe '(return 'nil)))) ; may need a jump around go code. (define-tag (car vgol)) ; here we are... (mapc '(lambda (x) (outinst !cmpaq (make-const (car x))) (outjump !tze (cdr x))) (car y)) (outinstag !tspbp !ab|badgo !*) (outjump !tra (car vgol))) (t (cond ((and (not effs) (or (not useless-code) labels-to-define)) (get-in-aq (comp ''nil)))))) (cond ((car exit) ; if ever returned from, ;; (cond ((and (not (atom (car codelist))) ; and instruction just outputted was a jump, ;; (eq (caar codelist) !tra) ;; (eq (cadar codelist) (car exit))) ;; (setq codelist (cdr codelist)) ;; (setq pc (1- pc)))) (define-tag (car exit)))) (setq framel (cdr framel)) ; remove prog frame. (cond (bindword (clearbb) (outinstag !tspbp !ab|unbind !*) (setq arg-height (- arg-height bind-size)) (setq framel (cdr framel)))) (mapc '(lambda (x) (setq null-var-list (delq (car x) null-var-list 1)) (do slot slotlist (cdr slot) (null slot) (cond ((eq (car slot) x) (rplaca slot nil) (return nil))))) locals) (setq bvars obvars prog-for-effs (cdr prog-for-effs)) ; pop effs list for progs. (setq cnt (+ 2 cnt)) (clearaq) ; not sure its needed, but be safe here. (return (setq AQ-state nil AQ (ncons (gensym)))))) (cons nil vgol) ;nil means no variable go at this level, may be rplaca'ed to a tag later. (cons nil exit))) ;nil means no returns from this prog, rplaca'ed to a tag if one gets done. ;;; Routines to generate code for defpl1 subrs (defun comp-cons-string (y) ;cons a string of spcified size (clearaq) (clearbb) ;clobbers these regs (outinstag !ldq (left (car y)) !dl) ;get length in q register (outinstag !tspbp !ab|cons-string-op !*);call operator to get the string (setq AQ (ncons (gensym)))) ;and the result is returned in aq (also in bb but we don't need it there) (defun comp-pack-ptrs (y) ;y is list of symbols and pdl cells to pack them out of ;i.e. copy ptrs from pdl into packed fixnums (do ((y y (cddr y)) (symb) (cell)) ((null y)) (setq symb (car y) cell (left (logand 77777 (cadr y)))) ; Note that type will already have been set by lambda binding (outinstag !eppbp cell !ab-x7*) (outarith !sprpbp (get-home symb)))) (defun comp-unpack-ptrs (y) ;y is list of symbols and pdl cells to unpack them inot (do ((y y (cddr y)) (symb) (cell)) ((null y)) (setq symb (car y) cell (left (logand 77777 (cadr y)))) (outarith !lprpbp (get-home symb)) ;pick fixnum as a pointer (outinstag !spribp cell !ab-x7) )) ;put down in unpacked format ; Note that the following function does not comp the variables in ; its arguments. This is because pass 1 doesn't either. This stuff ; is not considered to be lisp code, but just special stuff passed between passes (defun comp-pl1-call (y) ;generate code to call a pl1 program (clear-null-var-list) ;make sure all vars possess homes ((lambda (extname arglistcell argdesclist) (do ((argl argdesclist (cdr argl)) (argptrcell (+ 2000000 arglistcell) (+ 2000000 argptrcell)) (descptrcell (+ arglistcell (* 2000000 (1+ (length argdesclist)))) (+ 2000000 descptrcell)) (type) (var) (descrip) (cell)) ((null argl)) (setq type (caar argl) var (cadar argl) descrip (caddar argl) cell (left (logand 77777 (cadddr (car argl))))) (cond ;generate addressing code for arg and descriptor ((or (null type) ;just pass address of lisp object, constant descriptor (eq type '1+)) ;same but pass address + 1 (for number) (cond ((null type) (outinst !eppbp (get-home var))) ((outarith !eppbp (get-home var)))) (outinstag !spribp argptrcell !ab-x7) (outwrd (get-descriptor-address !eppbp descrip)) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'unmkd) ;pass address of unmkd pdl cell, constant descriptor (outinstag !eppbp cell !ab-x7) (outinstag !spribp argptrcell !ab-x7) (outwrd (get-descriptor-address !eppbp descrip)) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'string) ;must generate string pointer and descriptor (clearaq) ;pick up string into aq (outinst !ldaq (get-home var)) (clearbb) (outinstag !eppbb cell !ab-x7) ;bb -> where to put the descriptor (outinstag !tspbp !ab|create-string-descrip-op !*) ;store descriptor, set lb to string (outinstag !sprilb argptrcell !ab-x7) ;store argptr (outinstag !eppbp cell !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ;store descptr ((eq type 'varying-string) ;must call operator to set things up (clearaq) (outinst !ldaq (get-home var)) ;string to init from (clearbb) (outinstag !eppbb cell !ab-x7) ;bb -> where to put the descriptor (outinstag !tspbp !ab|create-varying-string-op !*) (outwrd descrip) ;output the length (outinstag !sprilb argptrcell !ab-x7) (outinst !staq (get-home var)) ;note string has been copied (outinstag !eppbp cell !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'array) ;must generate array pointer and descriptor (clearaq) ;pick up array into aq (outinst !ldaq (get-home var)) (clearbb) (outinstag !eppbb cell !ab-x7) ;bb -> where to put the descriptor (outinstag !tspbp !ab|create-array-descrip-op !*) (outwrd descrip) ;output the typeword for operator to check (outinstag !sprilb argptrcell !ab-x7) (outinstag !eppbp cell !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ((barf y "incorrect *pl1-call" barf))) ) ;end of do down arguments ;call pl1-call operator (clearbb) (clearaq) (outinstag !eppbb arglistcell !ab-x7) ;bb -> arglist (outinst !eaa (* 2000000 (length argdesclist))) ;au has 2*argcount (outinstag !tspbp !ab|pl1-call-op !*) ;make the call (outwrd (get-pl1-link extname)) ;get address of callee, xec'ed by opr ) ;done (cadr y) (left (logand 77777 (car y))) (cddr y))) (defun get-descriptor-address (opc x) ;x is a descriptor image, opc is opcode (setq x (get-literal-addr (make-const x))) ;assign descriptor an address in the text section (cons 'literal (logor opc !ic (left (- x pc -1))))) ;and return code to put address in ptr ;Note this will allocate 2 words for each descriptor (defun pass2 (ll body type fn-name) ; main pass2 interface.... ((lambda (intime codelist arg-height temp-size framel bump-arg-height ll-length literal-size AQ AQ-state BB effs slotlist slot-types useless-code loadlist bvars null-var-list slotx literal-start bind-size cnt p1cnt literal-list) (clear-out-literals) (clear-out-useless-fns) (setq entry-list (cons (logor (left (cdr defdat)) pc) entry-list)) (setq functions-defined (cons (cons type fn-name) functions-defined)) (setq codelist (cons nil codelist)) ; this marks our function's entry point, holding space for an eppap instruction. (mapc '(lambda (x) (and (specialp x) (setq bind-size (+ 4 bind-size)))) ll) (cond ((memq type '(expr fexpr)) ; normal case... (setq ll-length (cond ((and (eq type 'fexpr) ll (cdr ll)) ; fexpr with second formal param (cond ((cddr ll) (barf fn-name "has too many formal parameters to be an fexpr" data))) (outinst !eaq (list 'temp 2)) ; fabricating a pdl pointer (outinst !qrl (left 18.)) (outinstag !orq (left -2) !du) (outinstag !lda (left !fixnum-type) !dl) (outinst !staq (list 'temp 2)) 2.) ((eq type 'fexpr) (or ll (setq temp-size 2)) 2) (t (* (length ll) 2)))) (cond ((not (= bind-size 0)) (setq arg-height (+ arg-height bind-size)) (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)))) (setq bvars (append ll bvars)) ; variables bound are put on bvars. (do ll ll (cdr ll) (null ll) ; scan over lambda list. (cond ((specialp (car ll)) ; if special.... (outbindwrd (make-const (car ll)) (list 'temp (- temp-size bind-size))) ; gen binding from this temp. (setq slot-types (nconc slot-types (ncons (get (car ll) 'number)))) (setq slotlist (nconc slotlist (ncons nil)))) ; free the arg slot. (t (setq slot-types (nconc slot-types (ncons (get (car ll) 'number)))) (setq slotlist (nconc slotlist (ncons (cons (car ll) 'home)))))) (setq temp-size (+ 2 temp-size)))) ((eq type 'lexpr) (setq ll-length 0 bvars (cons (car ll) bvars)) (outinstag !eax7 !ab|2 !x7) ; get room on unmarked stack. (outinstag !eppbp (list 'temp 0) !x5) ; get pointer to beginning of args. (outinstag !spribp !ab|-2 !x7) ; save in space provided. (cond ((specialp (car ll)) (setq bind-size 8. ; above calculation decieving! more bindings than thought of. arg-height bind-size) (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)) (outwrd (cons 'bindtemp !bindargatom)) (outbindwrd (make-const (car ll)) 'nargs)) (t (setq bind-size 4 arg-height bind-size temp-size 2) (setq slotlist (ncons (cons (car ll) 'home))) (outinstag !eaa 0 !x5) (outinstag !neg 0 !du) (outinstag !ldq !lsubrhack !du) ; number type field shifted left 19. (outinst !llr 21000000) ; rotate things around a bit. (outinst !staq (list 'temp 0)) ; and store stuff. (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)) (outwrd (cons 'bindtemp !bindargatom)))))) (get-in-aq (comp body)) ; compute the value... (cond ((not (= bind-size 0)) (outinstag !tspbp !ab|unbind !*))) (cond ((eq type 'lexpr) (outinstag !eppap !ab|-2 !x7*) ; back up stack pointer. (outinstag !eax7 !ab|-2 !x7)) ; and unmarked pointer too. ((plusp temp-size) (outinst !eppap (logor !ap| (left (logand 77777 (minus temp-size))))))) (outjumptag !tra !ab|return !*) ; got to return operator. (cond (loadlist (barf loadlist "left on loadlist" barf))) (or (= p1cnt cnt) (barf (list p1cnt cnt ) "are unequal pass1 and pass2 counts." barf)) (initialize-slot-types) ; set slot-types to list of instructions to init slotlist type fields from. (cond ((not (= ll-length temp-size)) (setq pc (1+ pc) literal-start (1- literal-start)))) ; if we have to add an instruction... (cond (literal-list (cond ((oddp pc) (setq codelist (cons 0 codelist) pc (1+ pc)))) (setq literal-start (+ pc literal-start)) (mapc '(lambda (x) (setq codelist (cons (cadr x) (cons (cond ((fixp (cadr x)) !fixnum-type) (t !flonum-type)) codelist)) pc (+ 2 pc))) (nreverse literal-list)))) (do scan functions-called (cdr scan) (or (null scan) (fixp (car scan))) (rplaca scan (make-call-link (car (setq ll (cdar scan))) (cadr ll) (caddr ll) (cadddr ll)))) (do scan array-links (cdr scan) (or (null scan) (fixp (car scan))) (rplaca scan (make-array-link-control-word (car (setq ll (cdar scan))) (cadr ll) (cadddr ll)))) (do ((code codelist (cdr code)) (word)) ((null (setq word (car code))) ; if found the beginning of this function... (cond ((= ll-length temp-size) ; if no need for room other than the args... (setq slot-types (nconc slot-types (cdr code))) ; slot-types might be nil here. (rplaca code (car slot-types)) (rplacd code (cdr slot-types))) ; splice in code to init types (t (setq slot-types (nconc slot-types (cons (logor !eppap !ap| (left (- temp-size ll-length))) (cdr code)))) (rplaca code (car slot-types)) (rplacd code (cdr slot-types))))) ;spice in code here. (cond ((numberp word)) ((eq (car word) 'temp) (rplaca code (logand 77777777777 (- (cdr word) (left temp-size))))) ((eq (car word) 'literal) (rplaca code (+ (cdr word) (left literal-start)))) ((eq (car word) 'function) ) ((eq (car word) 'array) ) ((eq (car word) 'bindtemp) (rplaca code (add-right-half (minus temp-size) (cdr word)))) ((eq (car word) 'bindliteral) (rplaca code (add-right-half literal-start (cdr word)))))) (and time-option (progn (princ "Code generation time = ") (princ (quotient (- (runtime) intime) 1.0e6))(terpri))) codelist ;return new codelist. if compilation fails ; before this point, codelist will be unchanged. ) (cond (time-option (runtime)) (t 0)) codelist 0 0 nil 0 0 0 nil nil nil nil nil nil nil nil nil nil nil 0 0 1 cnt nil)) (defun add-right-half (x y) ; add x to right halfword of y, returning left half of y logor result of add. (logor (logand 777777_18. y) (logand 777777 (+ x (logand 777777 y))))) (defun clear-out-literals () (do i 0 (1+ i) (= i !const-table-size) (mapc '(lambda (x) (and (or (and (fixp (cadr x)) (smallnump (cadr x))) (floatp (cadr x))) (rplacd (cdr x) nil))) ; forget all literals (const-table i)))) (defun clear-out-useless-fns () ; gets rid of functional temp references... (do i 0 (1+ i) (= i !fcn-table-size) (mapc '(lambda (x) (and (eq (caadr x) 'temp) ; is temp. (rplacd (cddddr x) nil) ; forget we had one. )) (fcn-table i)))) (defun make-array-link-control-word (array type ndims) (logor (lsh (cond ((eq type 'fixnum) 2) ((eq type 'flonum) 3) (t 0)) 27.) ;type code (lsh ndims 18.) ;number of dimensions (1+ (get-constant-addr array)))) (defun initialize-slot-types () ; setq's slot-types to a list of instructions to initialize the types of slots. (setq slot-types (do ((slot slot-types (cdr slot)) (tempi (- temp-size) (+ 2 tempi)) (inst-list nil)) ((null slot) inst-list) (and (car slot) ; if typed item, (prog2 (or inst-list ; check to see if inst-list has been updated. (setq inst-list (list (logor !ldaq !ab|type-fields)) pc (1+ pc) literal-start (1- literal-start))) (setq pc (1+ pc) literal-start (1- literal-start) inst-list (xcons inst-list (logor (cond ((eq (car slot) 'fixnum) !sta) ((eq (car slot) 'flonum) !stq)) !ap| (left (logand 77777 tempi)))))))))) (defun finish-code () (prog (function-rel array-link-rel type-list def-length intime) (setq intime (cond (total-time (runtime)) (t 0))) (setq function-rel 0 def-length 0 type-list (subst nil nil '((fixnum) (flonum) (string) (bignum) (symbol)(list)))) (map '(lambda (l) (setq function-rel (1+ function-rel)) (rplaca l (analyze (cadar l) type-list))) constant-list) (mapc '(lambda (x) (rplaca x (cdr (assq (car x) '((nil . 0) (expr . 1_18.) (lexpr . 2_18.) (fexpr . 3_18.))))) (rplacd x (analyze (cdr x) type-list)) (setq def-length (1+ def-length))) functions-defined) (fix-type-list type-list) (setq array-link-rel (+ function-rel (length entry-list) (length functions-called))) (map '(lambda (l) (rplaca l (get-object-offset (car l)))) constant-list) (map '(lambda (l) (rplaca l (logor (caar l) (get-object-offset (cdar l))))) functions-defined) (map '(lambda (l) (and (not (atom (car l))) (cond ((eq (caar l) 'function) (rplaca l (+ (cdar l) (lsh function-rel 19.)))) ((eq (caar l) 'pl1-link) (rplaca (car l) !Link15)) ;relocatable word ((eq (caar l) 'array) (rplaca l (+ (cdar l) (lsh array-link-rel 19.)))) (t (barf (car l) "funny word - finish-code" barf))))) codelist) (cg-util seg-name (cdr (nreverse codelist)) compiler-version (cons (length source-map) (nreverse source-map)) (car type-list) (cadr type-list) (caddr type-list) (cadddr type-list) (car (cddddr type-list)) (cadr (cddddr type-list)) (cons (length entry-list) (nreverse entry-list)) (cons function-rel (nreverse constant-list)) (cons (length functions-called) (nreverse functions-called)) (cons def-length (nreverse functions-defined)) (cons (length array-links) (nreverse array-links)) (cons (length pl1-link-list) (nreverse pl1-link-list)) ) (and total-time (progn (terpri) (princ "Object creation time = ") (prin1 (//$ (float (- (runtime) intime)) 1000000.0)) (terpri))))) (defun init-code-generator () (setq constant-size 0 fcn-size 0 array-size 0 functions-defined nil array-links nil pl1-link-list nil pl1-link-size 10 functions-called nil entry-list nil constant-list nil) (fillarray 'fcn-table '(nil)) (fillarray 'const-table '(nil)) (setq pc 0 codelist (ncons nil))) (defun make-call-link (fn-name snap? type nargs) (logor (cond ((eq (car fn-name) 'temp) (lsh (- (cadr fn-name) temp-size) 12.)) (t (logor 2000 (lsh (+ 1 (get-constant-addr fn-name)) 12.)))) ; constant-list munged by now. (cond (snap? 4000) (t 0)) (cond ((eq type 'fsubr) 1001) ((eq type 'lsubr) 777) (t nargs)))) ;;; function to analyze constants referenced by lisp compiled code (defun analyze (x type-lists) ;; x is the object, type-lists is a list of the form ;; ((fixnum ...) ;; (flonum ...) ;; (string ...) ;; (bignum ...) ;; (symbol ...) ;; (list ..)) ((lambda (type) ((lambda (l) (cons type ; returns ( .) (cond ((eq type 'nil) 0) ((not (eq type 'list)) (do ((scan (cdr l) (cdr scan)) (last l scan) (i 1 (1+ i))) ((null scan) (rplacd last (ncons x)) i) (cond ((equal x (car scan)) (return i))))) ((eq (cdr x) gofoo) ;load-time evaluated constant (setq type (analyze (car x) type-lists)) (or (eq (car type) 'list) (barf type "bad load-time constant" barf)) (logor (cdr type) 400000)) ;set loadtime bit (t (do ((scan (cdr l) (cdr scan)) (last l scan) (i 1 (1+ i))) ((null scan) (list-analyze x i last type-lists)) (cond ((eq x (caar scan)) (return i))))) ))) (assq type type-lists))) (and x (typep x)))) ;;; function to insert list-type objects into type-lists. ;;; relies on the fact that sublists are not eq to existing lists. ;;; thus inserts all of the skeleton into the type-list and analyze's only ;;; the fringes. (declare (special list-offset list-last)) (defun list-analyze (x list-offset list-last type-lists) (setq x (ncons (cons x (cons (lanalyze (car x) type-lists) (lanalyze (cdr x) type-lists))))) ; changes list-last, list-offset. (rplacd list-last x) list-offset) (defun lanalyze (x type-lists) ; basic analyzer (cond ((atom x) (analyze x type-lists)) ; if atomic, use ordinary analyzer. (t (setq x (ncons (cons nil (cons (lanalyze (car x) type-lists) (lanalyze (cdr x) type-lists))))) ;; note that we forget the value of x here, unlike in list-analyze, because ;; we know that its value will never be eq to any other list we will see. (rplacd list-last x) (prog2 (setq list-last (cdr list-last)) ; update the end of the list pointer (cons 'list list-offset) (setq list-offset (+ list-offset 1)))))) ; update the count of items. (declare (special type-offsets)) (defun fix-type-list (type-list) ;; takes type-list, and rplaca's lengths into type buckets, and ;; fixes up the cons list to be a list of 36 bit numbers. ;; generates the special variable type-offsets for use by ;; get-object-offset ((lambda (base-offset) (setq type-offsets (ncons (cons nil 0))) (mapc '(lambda (tl) (setq type-offsets (cons (cons (car tl) base-offset) type-offsets)) (cond ((eq (car tl) 'list) (map '(lambda (x) (rplaca x (logor (lsh (get-object-offset (cadar x)) 18.) (get-object-offset (cddar x))))) (cdr tl)))) (setq base-offset (+ (car (rplaca tl (length (cdr tl)))) base-offset))) type-list)) 0)) (defun get-object-offset (x) ;; returns absolute offset in constant table of object (+ (cdr x) (cdr (assq (car x) type-offsets)))) (declare (eval (read))) ; do next thing at compile time. (sstatus macro /! nil) ;;; ;;; Eternal compiler history maintained here automatically. ;;; (declare (defun get-compiler-history-variable (x) (let ((obarray obarray)) (use c) (let ((var (intern (copysymbol x nil)))) (cond ((boundp var)(symeval var)) (t nil))))) (read)) ;;interpreter only (defun get-compiler-history-variable (x) 'Interpreter) (defun cg-signature-history-macro macro (x) (list 'progn ''compile (list 'setq 'cg-compile-date (list 'quote (list (status date)(status daytime))) 'cg-compiler-history (list 'quote (or (get-compiler-history-variable 'compiler-history) (get-compiler-history-variable 'compiler-version)))))) (cg-signature-history-macro) INCLUDE FILE >dumps>old_dumps>lisp_stuff>work>include>compiler-macros.incl.lisp ;;; BEGIN INCLUDE FILE compiler-macros.incl.lisp ;;; This file contains useful macros used by the lisp_compiler. (defun displace macro (l) ((lambda (a1 a2) (rplaca a1 (car a2)) (rplacd a1 (cdr a2)) (list 'quote a1)) (eval (cadr l)) (eval (caddr l)))) (defun barf macro (x) (displace x (list 'printmes (cadr x) (caddr x) (list 'quote (cadddr x))) )) (defun warn macro (x) (displace x (list 'printmes (cadr x) (caddr x) ''warn))) (defun specialp macro (x) (displace x (list 'get (cadr x) '(quote special)))) (defun memq-max macro (x) (displace x (list 'quote 11.))) ; optimize (memq x '(...)) into ; an or of 10. or fewer clauses. (defun assq-max macro (x) (displace x (list 'quote 4))) ;max 3-dotted-pair inline assq (defun push macro (x) (displace x (list 'setq (caddr x) (list 'cons (cadr x) (caddr x))))) (defun pop macro (x) (displace x (list 'setq (cadr x) (list 'cdr (cadr x))))) (defun pnamep macro (x) (displace x (subst (cadr x) 'x '(eq (typep x) 'symbol)))) ;;; END INCLUDE FILE compiler-macros.incl.lisp INCLUDE FILE >dumps>old_dumps>lisp_stuff>work>include>compiler-badfns.incl.lisp ;;; BEGIN INCLUDE FILE compiler-badfns.incl.lisp ;;; This defines the badfns macro, which expands into a list ;;; of the system functions which are not compiled in line ;;; and (but?) which can have bad side-effects (change special variables) ;;; extracted from main code of compiler and made correct 8 May 1973 DAM. (defun macro badfns (x) (displace x (list 'quote '( *rset ;in case we change this to use a special variable. apply break cline ;you never know close eval inpush ioc iog makunbound read readch readstring status sstatus tyi tyipeek ufile uread uwrite ukill )))) ;;; END INCLUDE FILE compiler-badfns.incl.lisp Functions Defined Name Offset Offset Name add-right-half 32712 0 cg-util analyze 34124 120 clearaq betterval 1500 126 storeaq? call-1-argument-subr 12454 227 put-type-in-aq carcdr 14540 310 damned-variable carinit 14250 434 clearslotlist cg-util 0 504 freeable cleanup-special-var-loads 6007 613 findtemp cleanup-var-load 6345 730 saveaq cleanup-var-loads 5753 1062 clearbb clear-null-var-list 17325 1066 storebb? clear-out-literals 32730 1130 savebb clear-out-useless-fns 33006 1172 in-aq clearaq 120 1223 in-Q clearbb 1062 1246 iloc clearslotlist 434 1352 locvalue comp 7634 1500 betterval comp-catches-and-errsets 23440 1564 ilocs comp-cons-string 30240 1607 outinst comp-pack-ptrs 30270 2160 outbindwrd comp-parison 22234 2352 tra-adjust comp-pl1-call 30412 2604 outjump comp-type-test 22110 2736 outwrd comp-unpack-ptrs 30340 3000 define-tag comp0 7660 3266 fix-refs compandor 17202 3430 get-pl1-link comparith 4202 3460 get-literal-addr comparray 26270 3510 get-constant-addr compcarcdr 14401 3540 get-fcn-addr compcond 16652 3575 get-array-link-addr compe 7646 3632 outarith comperr 24406 4012 get-fixnum compfloat 5306 4035 get-fixnum-commu compform 10117 4125 loadarith compfsubr 13614 4202 comparith compgo 24606 4452 negate-fixnum compile-list-and-list* 13302 4554 compshift compiog 25062 5064 outfloat complambda 26610 5202 get-flonum complsubr 12532 5241 loadfloat compmemq 16150 5306 compfloat compprog 27402 5522 negate-flonum compred 17373 5564 cv-float-to-typed compreturn 24510 5642 gotvalue compset 15716 5676 goodval compsetq 14574 5753 cleanup-var-loads compshift 4554 6007 cleanup-special-var-loads compstore 26350 6054 savevalue compsubr 10566 6174 fixidups compthrow 24211 6250 fix-special-idups comrplaca 15730 6345 cleanup-var-load comrplacd 16034 6466 make-call contents 7566 7206 get-function cv-float-to-typed 5564 7333 storearg damned-variable 310 7351 storearg-bb define-tag 3000 7366 force-arg-height do-rar-setq 15122 7411 get-in-aq do-setq 14622 7550 remove easygo 24776 7566 contents find-nth 24710 7634 comp findtemp 613 7646 compe finish-code 33232 7660 comp0 fix-refs 3266 10006 make-const fix-special-idups 6250 10110 get-const fix-type-list 34454 10117 compform fixidups 6174 10566 compsubr force-arg-height 7366 12454 call-1-argument-subr freeable 504 12532 complsubr generate-array-reference 25174 13302 compile-list-and-list* get-array-link-addr 3575 13614 compfsubr get-const 10110 14250 carinit get-constant-addr 3510 14303 reduce-cars get-descriptor-address 31152 14401 compcarcdr get-fcn-addr 3540 14540 carcdr get-fixnum 4012 14574 compsetq get-fixnum-commu 4035 14622 do-setq get-flonum 5202 15122 do-rar-setq get-function 7206 15374 storevalue get-home 15632 15572 storevalue-bb get-in-aq 7411 15632 get-home get-literal-addr 3460 15716 compset get-object-offset 34572 15730 comrplaca get-pl1-link 3430 16034 comrplacd goodval 5676 16150 compmemq gotvalue 5642 16344 level-tag iloc 1246 16565 testnil ilocs 1564 16652 compcond in-Q 1223 17202 compandor in-aq 1172 17325 clear-null-var-list init-code-generator 33772 17373 compred initialize-slot-types 33122 22110 comp-type-test known-fixnum 22154 22154 known-fixnum known-flonum 22204 22204 known-flonum lanalyze 34371 22234 comp-parison level-tag 16344 22754 test-sign list-analyze 34326 23240 try-comparative-and loadarith 4125 23440 comp-catches-and-errsets loadfloat 5241 24022 unwind locvalue 1352 24055 unwind-one-frame make-array-call 26170 24164 popap make-array-link 26572 24211 compthrow make-array-link-control-word 33060 24406 comperr make-call 6466 24510 compreturn make-call-link 34046 24606 compgo make-const 10006 24710 find-nth negate-fixnum 4452 24736 unwindgoret negate-flonum 5522 24776 easygo outarith 3632 25062 compiog outbindwrd 2160 25174 generate-array-reference outfloat 5064 26170 make-array-call outinst 1607 26270 comparray outjump 2604 26350 compstore outwrd 2736 26572 make-array-link pass2 31210 26610 complambda popap 24164 27402 compprog put-type-in-aq 227 30240 comp-cons-string reduce-cars 14303 30270 comp-pack-ptrs remove 7550 30340 comp-unpack-ptrs saveaq 730 30412 comp-pl1-call savebb 1130 31152 get-descriptor-address savevalue 6054 31210 pass2 storeaq? 126 32712 add-right-half storearg 7333 32730 clear-out-literals storearg-bb 7351 33006 clear-out-useless-fns storebb? 1066 33060 make-array-link-control-word storevalue 15374 33122 initialize-slot-types storevalue-bb 15572 33232 finish-code test-sign 22754 33772 init-code-generator testnil 16565 34046 make-call-link tra-adjust 2352 34124 analyze try-comparative-and 23240 34326 list-analyze unwind 24022 34371 lanalyze unwind-one-frame 24055 34454 fix-type-list unwindgoret 24736 34572 get-object-offset Functions Referenced abs comrplacd loadfloat add-right-half contents locvalue analyze cv-float-to-typed make-array-call append damned-variable make-array-link assq define-tag make-array-link-control-word betterval delq make-call call-1-argument-subr delq make-call-link carcdr do-rar-setq make-const cg-util do-setq makunbound cleanup-special-var-loads easygo max cleanup-var-load equal minus cleanup-var-loads fillarray nconc clear-null-var-list find-nth negate-fixnum clear-out-literals findtemp negate-flonum clear-out-useless-fns fix-refs nreverse clearaq fix-special-idups oddp clearbb fix-type-list outarith clearslotlist fixidups outbindwrd comp float outfloat comp-catches-and-errsets force-arg-height outinst comp-cons-string freeable outjump comp-pack-ptrs generate-array-reference outwrd comp-parison gensym popap comp-pl1-call get prin1 comp-type-test get-array-link-addr princ comp-unpack-ptrs get-const printmes comp0 get-constant-addr put-type-in-aq compandor get-descriptor-address putprop comparith get-fcn-addr reduce-cars comparray get-fixnum remove compcarcdr get-fixnum-commu remprop compcond get-flonum runtime compe get-function saveaq comperr get-home savebb compfloat get-in-aq savevalue compform get-literal-addr storeaq? compfsubr get-object-offset storearg compgo get-pl1-link storearg-bb compile-list-and-list* getl storebb? compiog goodval storevalue complambda gotvalue storevalue-bb complsubr iloc subst compmemq ilocs sxhash compprog in-Q sysp compred in-aq terpri compreturn initialize-slot-types test-sign compset known-fixnum testnil compsetq known-flonum tra-adjust compshift lanalyze try-comparative-and compstore length typep compsubr level-tag unwind compthrow list-analyze unwind-one-frame comrplaca loadarith unwindgoret ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved