Return to vector.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt

Annotation of 43BSD/ucb/lisp/liszt/vector.l, revision 1.1

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file vector
        !             3:    "$Header: vector.l,v 1.11 83/11/22 10:13:48 jkf Exp $")
        !             4: 
        !             5: ;;; ----       v e c t o r                     vector referencing
        !             6: ;;;
        !             7: ;;;                            -[Fri Nov 11 22:35:50 1983 by jkf]-
        !             8: 
        !             9: 
        !            10: (defun cc-vset ()
        !            11:    ;;  Set a vector created via 'vector'.
        !            12:    (d-vset 'lisp))
        !            13: 
        !            14: (defun cc-vref ()
        !            15:    ;;  Reference a vector created via 'vector'.
        !            16:    (d-vref 'lisp))
        !            17: 
        !            18: (defun cc-vseti-byte ()
        !            19:    ;;  Set a vector created via 'vectori-byte'.
        !            20:    (d-vset 'byte))
        !            21: 
        !            22: (defun cc-vrefi-byte ()
        !            23:    ;;  Reference a vector created via 'vectori-byte'.
        !            24:    (d-vref 'byte))
        !            25: 
        !            26: (defun cc-vseti-word ()
        !            27:    ;;  Set a vector created via 'vectori-word'.
        !            28:    (d-vset 'word))
        !            29: 
        !            30: (defun cc-vrefi-word ()
        !            31:    ;;  Reference a vector created via 'vectori-word'.
        !            32:    (d-vref 'word))
        !            33: 
        !            34: (defun cc-vseti-long ()
        !            35:    ;;  Set a vector created via 'vectori-long'.
        !            36:    (d-vset 'long))
        !            37: 
        !            38: (defun cc-vrefi-long ()
        !            39:    ;;  Reference a vector created via 'vectori-long'.
        !            40:    (d-vref 'long))
        !            41: 
        !            42: ;--- d-vset :: handle all types of vset's
        !            43: (defun d-vset (type)
        !            44:    ;;  Generic vector store.  Type is either 'lisp', 'byte', 'word',
        !            45:    ;; or 'long'.
        !            46:    (let ((vect (cadr v-form))
        !            47:         (index (caddr v-form))
        !            48:         (val (cadddr v-form))
        !            49:         (vect-addr) (index-addr)
        !            50:         (vect-val) (fetchval)
        !            51:         (temp) (size)
        !            52:         (vec-reg #+for-vax 'r0 #+for-68k 'a0)
        !            53:         (val-reg #+for-vax 'r1 #+for-68k 'd1)
        !            54:         (index-reg '#.fixnum-reg)
        !            55:         (temp-reg #+for-vax 'r4 #+for-68k 'd0)
        !            56:         (temp-areg #+for-vax 'bogus! #+for-68k 'a1)
        !            57:         (oklab (d-genlab))
        !            58:         (needlowcheck t))              ; t if must check lower index bounds
        !            59: 
        !            60:        #+for-68k (d-regused '#.fixnum-reg)
        !            61:        (makecomment `(doing vec set type ,type))
        !            62:        (if (fixp index)
        !            63:           then (if (<& index 0)
        !            64:                    then (comp-err "vector index less than 0 " v-form))
        !            65:                (setq needlowcheck nil))
        !            66: 
        !            67:        ; Compute the value to be stored...
        !            68:        ;
        !            69:        ; If we are doing an immediate vector, then get the value
        !            70:        ; instead of the boxed fixnum (in the case of byte), or
        !            71:        ; word/long.
        !            72:        (if (null (eq 'lisp type)) then (setq val `(cdr ,val)))
        !            73: 
        !            74:        (if (null (setq vect-val (d-simple val)))
        !            75:           then (let ((g-loc val-reg) g-cc g-ret)
        !            76:                    (d-exp val))
        !            77:                (setq vect-val val-reg)
        !            78:           else (setq vect-val (e-cvt vect-val)))
        !            79: 
        !            80:        ; make sure that we are not going to clobber val-reg...
        !            81:        (if (not (and (d-simple vect) (d-simple index)))
        !            82:           then ; val-reg could be clobbered when we do the
        !            83:                ; fetching of the vector or index values
        !            84:                (setq fetchval t)
        !            85:                (e-move vect-val (e-cvt 'stack)))
        !            86: 
        !            87:        ; Compute the index...
        !            88:        ;
        !            89:        (if (setq index-addr (d-simple index))
        !            90:           then (let ((g-loc vec-reg) g-cc g-ret)
        !            91:                    (d-exp vect))
        !            92:                (setq vect-addr vec-reg)        ; the vector op is in vec-reg
        !            93:                ; we really want the cdr of index (the actual number).
        !            94:                ; if we can do that simply, great.  otherwise we
        !            95:                ; bring the index into index-reg and then do the cdr ourselves
        !            96:                (if (setq temp (d-simple `(cdr ,index)))
        !            97:                    then (d-move temp index-reg)
        !            98:                    else (d-move index-addr index-reg)
        !            99:                         #+for-vax
        !           100:                         (e-move `(0 ,index-reg) index-reg)
        !           101:                         #+for-68k
        !           102:                         (progn
        !           103:                             (e-move index-reg 'a5)
        !           104:                             (e-move '(0 a5) index-reg)))
        !           105:                (setq index-addr index-reg)
        !           106:           else ; the index isn't computable simply, so we must
        !           107:                ; stack the vector location to keep it safe
        !           108:                (let ((g-loc 'stack) g-cc g-ret)
        !           109:                    (d-exp vect))
        !           110:                (push nil g-locs)
        !           111:                (incr g-loccnt)
        !           112:                ; compute index's value into index-reg
        !           113:                (d-fixnumexp index)
        !           114:                ; now put vector address into vec-reg
        !           115:                (d-move 'unstack vec-reg)
        !           116:                (decr g-loccnt)
        !           117:                (pop g-locs)
        !           118:                (setq vect-addr vec-reg
        !           119:                      index-addr index-reg)
        !           120:                ; must be sure that the cc's reflect the value of index-reg
        !           121:                (e-tst index-reg))
        !           122: 
        !           123:        ;   At this point, vect-addr (always vec-reg) contains the location of
        !           124:        ; the start of the vector,  index-addr (always index-reg) contains
        !           125:        ; the index value.
        !           126:        ;   The condition codes reflect the value of the index.
        !           127:        ; First we insure that the index is non negative
        !           128:        ; test must use a jmp in case the object file is large
        !           129:        ;
        !           130:        (if needlowcheck
        !           131:           then (e-write2 #+for-vax 'jgeq #+for-68k 'jpl oklab)
        !           132:                (e-write2 'jmp 'vecindexerr)
        !           133:                (e-label oklab)
        !           134:                (setq oklab (d-genlab)))
        !           135:        ;; now, we compare against the size of the vector
        !           136:        ;; the size of the vector is in bytes, we may want to shift this
        !           137:        ;; to reflect the size in words or longwords, depending on the
        !           138:        ;; type of reference
        !           139:        (if (eq type 'byte)
        !           140:           then ; can compare right away
        !           141:                (e-cmp index-addr `(-8 ,vect-addr))
        !           142:           else ; shift size into temp-reg
        !           143:                (setq size (if (eq type 'word) then 1 else 2))
        !           144:                #+for-vax
        !           145:                    (e-write4 'ashl (concat '$- size)
        !           146:                              `(-8 ,vect-addr) temp-reg)
        !           147:                #+for-68k
        !           148:                (progn
        !           149:                    (e-move `(-8 ,vect-addr) temp-reg)
        !           150:                    (e-write3 'asrl `($ ,size) temp-reg))
        !           151:                (e-cmp index-addr temp-reg)
        !           152:                (d-clearreg temp-reg))
        !           153:        ;; size is the number of objects, the index is 0 based so
        !           154:        ;; it must be less than the vector size
        !           155:        (e-write2 #+for-vax 'jlss #+for-68k 'jmi oklab)
        !           156:        (e-write2 'jmp 'vecindexerr)
        !           157:        (e-label oklab)
        !           158: 
        !           159:        (if fetchval
        !           160:           then ; unstack the value to store...
        !           161:                (e-move (e-cvt 'unstack) val-reg)
        !           162:                (setq vect-val val-reg))
        !           163: 
        !           164:        ;; if we get here then the access is in bounds
        !           165:        (if (eq type 'lisp)
        !           166:           then #+for-vax
        !           167:                (e-move vect-val `(0 ,vect-addr ,index-addr))
        !           168:                #+for-68k
        !           169:                (progn
        !           170:                    (e-move index-addr temp-reg)
        !           171:                    (e-write3 'asll '($ 2) temp-reg)
        !           172:                    (e-add vect-addr temp-reg)
        !           173:                    (e-move temp-reg temp-areg)
        !           174:                    (e-move vect-val `(0 ,temp-areg)))
        !           175:                (if g-loc (e-move vect-val (e-cvt g-loc)))
        !           176:                (if g-cc then (d-handlecc))
        !           177:           else (setq temp (cadr (assq type '((byte movb)
        !           178:                                              (word movw)
        !           179:                                              (long movl)))))
        !           180:                #+for-vax
        !           181:                (e-write3 temp vect-val `(0 ,vect-addr ,index-addr))
        !           182:                #+for-68k
        !           183:                (progn
        !           184:                    (e-move index-addr temp-reg)
        !           185:                    (caseq type
        !           186:                        (word (e-write3 'asll '($ 1) temp-reg))
        !           187:                        (long (e-write3 'asll '($ 2) temp-reg)))
        !           188:                    (e-write3 'lea `(% 0 ,vec-reg ,temp-reg) temp-areg)
        !           189:                    (if (eq type 'long)
        !           190:                        then (e-write3 temp vect-val `(0 ,temp-areg))
        !           191:                        else (e-move vect-val 'd1)
        !           192:                             (e-write3 temp 'd1 `(0 ,temp-areg))))
        !           193:                (if g-loc
        !           194:                    then (if (eq type 'byte)
        !           195:                             then ; all bytes values are within the fixnum
        !           196:                                  ; range, we convert them to immediate
        !           197:                                  ; fixum with ease.
        !           198:                                  #+for-vax
        !           199:                                  (progn
        !           200:                                      (e-write4 'ashl '($ 2)
        !           201:                                                index-reg index-reg)
        !           202:                                      (e-write3 'movab
        !           203:                                                `(5120 ,index-reg)
        !           204:                                                (e-cvt g-loc)))
        !           205:                                  #+for-68k
        !           206:                                  (progn
        !           207:                                      (e-move index-reg temp-reg)
        !           208:                                      (e-write3 'asll '($ 2) temp-reg)
        !           209:                                      (e-move temp-reg temp-areg)
        !           210:                                      (e-move
        !           211:                                                (e-cvt '(fixnum 0))
        !           212:                                                temp-reg)
        !           213:                                      (e-write3 'lea
        !           214:                                                `(% 0 ,temp-areg ,temp-reg)
        !           215:                                                temp-areg)
        !           216:                                      (e-move
        !           217:                                                temp-areg
        !           218:                                                (e-cvt g-loc)))
        !           219:                             else ; must convert the hard way
        !           220:                                  (e-call-qnewint)
        !           221:                                  (d-clearreg)
        !           222:                                  (if (not (eq g-loc 'reg))
        !           223:                                      then (d-move 'reg g-loc)))
        !           224:                         ; result is always non nil
        !           225:                         (if (car g-cc) then (e-goto (car g-cc)))
        !           226:                 elseif (car g-cc) then (e-goto (car g-cc))))
        !           227:        (d-vectorindexcode)))
        !           228: 
        !           229: ;--- d-vref :: handle all types of vref's
        !           230: (defun d-vref (type)
        !           231:    ;;  Generic vector reference.  Type is either 'lisp', 'byte', 'word',
        !           232:    ;; or 'long'.
        !           233:    (let ((vect (cadr v-form))
        !           234:         (index (caddr v-form))
        !           235:         (vect-addr) (index-addr) (temp) (size)
        !           236:         (vec-reg #+for-vax 'r0 #+for-68k 'a0)
        !           237:         (index-reg '#.fixnum-reg)
        !           238:         (temp-reg #+for-vax 'r4 #+for-68k 'd0)
        !           239:         (temp-areg #+for-vax 'rX #+for-68k 'a1)
        !           240:         (oklab (d-genlab))
        !           241:         (needlowcheck t))  ; t if must check lower index bounds
        !           242: 
        !           243:        #+for-68k (d-regused '#.fixnum-reg)
        !           244:        (makecomment `(doing vec ref type ,type))
        !           245:        (if (fixp index)
        !           246:           then (if (<& index 0)
        !           247:                    then (comp-err "vector index less than 0 " v-form))
        !           248:                (setq needlowcheck nil))
        !           249: 
        !           250:        (if (setq index-addr (d-simple index))
        !           251:           then (let ((g-loc vec-reg) g-cc g-ret)
        !           252:                    (d-exp vect))
        !           253:                (setq vect-addr vec-reg)        ; the vector op is in vec-reg
        !           254:                ; we really want the cdr of index (the actual number).
        !           255:                ; if we can do that simply, great.  otherwise we
        !           256:                ; bring the index into index-reg and then do the cdr ourselves
        !           257:                (if (setq temp (d-simple `(cdr ,index)))
        !           258:                    then (d-move temp index-reg)
        !           259:                    else (d-move index-addr index-reg)
        !           260:                         #+for-vax
        !           261:                         (e-move `(0 ,index-reg) index-reg)
        !           262:                         #+for-68k
        !           263:                         (progn
        !           264:                             (e-move index-reg 'a5)
        !           265:                             (e-move '(0 a5) index-reg)))
        !           266:                (setq index-addr index-reg)
        !           267:           else ; the index isn't computable simply, so we must
        !           268:                ; stack the vector location to keep it safe
        !           269:                (let ((g-loc 'stack) g-cc g-ret)
        !           270:                    (d-exp vect))
        !           271:                (push nil g-locs)
        !           272:                (incr g-loccnt)
        !           273:                ; compute index's value into index-reg
        !           274:                (d-fixnumexp index)
        !           275:                ; now put vector address into vec-reg
        !           276:                (d-move 'unstack vec-reg)
        !           277:                (decr g-loccnt)
        !           278:                (pop g-locs)
        !           279:                (setq vect-addr vec-reg
        !           280:                      index-addr index-reg)
        !           281:                ; must be sure that the cc's reflect the value of index-reg
        !           282:                (e-tst index-reg))
        !           283:        
        !           284:        ; at this point, vect-addr (always vec-reg) contains the location of
        !           285:        ; the start of the vector,  index-addr (always index-reg) contains
        !           286:        ; the index value.  the condition codes reflect the value of
        !           287:        ; the index
        !           288:        ; First we insure that the index is non negative
        !           289:        ; test must use a jmp in case the object file is large
        !           290:        (if needlowcheck
        !           291:           then (e-write2 #+for-vax 'jgeq #+for-68k 'jpl oklab)
        !           292:                (e-write2 'jmp 'vecindexerr)
        !           293:                (e-label oklab)
        !           294:                (setq oklab (d-genlab)))
        !           295: 
        !           296:        ; now, we compare against the size of the vector
        !           297:        ; the size of the vector is in bytes, we may want to shift this
        !           298:        ; to reflect the size in words or longwords, depending on the
        !           299:        ; type of reference
        !           300:        (if (eq type 'byte)
        !           301:           then ; can compare right away
        !           302:                (e-cmp index-addr `(-8 ,vect-addr))
        !           303:           else ; shift size into temp-reg
        !           304:                (setq size (if (eq type 'word) then 1 else 2))
        !           305:                #+for-vax
        !           306:                (e-write4 'ashl (concat '$- size) `(-8 ,vect-addr) temp-reg)
        !           307:                #+for-68k
        !           308:                (progn
        !           309:                    (e-move `(-8 ,vect-addr) temp-reg)
        !           310:                    (e-write3 'asrl `($ ,size) temp-reg))
        !           311:                (e-cmp index-addr temp-reg)
        !           312:                (d-clearreg temp-reg))
        !           313:        ; size is the number of objects, the index is 0 based so
        !           314:        ; it must be less than the vector size
        !           315:        (e-write2 #+for-vax 'jlss #+for-68k 'jmi oklab)
        !           316:        (e-write2 'jmp 'vecindexerr)
        !           317:        (e-label oklab)
        !           318: 
        !           319:        ;; if we get here then the access is in bounds
        !           320:        (if g-loc
        !           321:           then ; we care about the value.
        !           322:                ; if the value is one of the fixnum types, then we
        !           323:                ; move the value to index-reg so it can be fixnum converted
        !           324:                (if (eq type 'lisp)
        !           325:                    then #+for-vax
        !           326:                         (e-move `(0 ,vect-addr ,index-addr)
        !           327:                                   (e-cvt g-loc))
        !           328:                         #+for-68k
        !           329:                         (progn
        !           330:                             (e-move index-addr temp-reg)
        !           331:                             (e-write3 'asll '($ 2) temp-reg)
        !           332:                             (e-add vect-addr temp-reg)
        !           333:                             (e-move temp-reg temp-areg)
        !           334:                             (e-move `(0 ,temp-areg) (e-cvt g-loc)))
        !           335:                         (if g-cc then (d-handlecc))
        !           336:                    else #+for-vax
        !           337:                         (progn
        !           338:                             (setq temp (cadr (assq type '((byte cvtbl)
        !           339:                                                           (word cvtwl)
        !           340:                                                           (long movl)))))
        !           341:                             (e-write3 temp
        !           342:                                       `(0 ,vect-addr ,index-addr)
        !           343:                                       index-reg))
        !           344:                         #+for-68k
        !           345:                         (progn
        !           346:                             (setq temp
        !           347:                                   (cadr (assq type '((byte movb)
        !           348:                                                      (word movw)
        !           349:                                                      (long movl)))))
        !           350:                             (caseq type
        !           351:                                    (word (e-write3 'asll '($ 1) index-reg))
        !           352:                                    (long (e-write3 'asll '($ 2) index-reg)))
        !           353:                             (e-write3 'lea `(% 0 ,vec-reg ,index-reg)
        !           354:                                       temp-areg)
        !           355:                             (if (memq type '(byte word))
        !           356:                                 then (e-write2 'clrl index-reg))
        !           357:                             (e-write3 temp `(0 ,temp-areg) index-reg))
        !           358:                         (if (eq type 'byte)
        !           359:                             then ; all bytes values are within the fixnum
        !           360:                                  ; range, we convert them to immediate
        !           361:                                  ; fixum with ease.
        !           362:                                  #+for-vax
        !           363:                                  (progn
        !           364:                                      (e-write4 'ashl '($ 2)
        !           365:                                                index-reg index-reg)
        !           366:                                      (e-write3 'movab
        !           367:                                                `(5120 ,index-reg)
        !           368:                                                (e-cvt g-loc)))
        !           369:                                  #+for-68k
        !           370:                                  (progn
        !           371:                                      (e-write3 'asll '($ 2) index-reg)
        !           372:                                      (e-move index-reg temp-areg)
        !           373:                                      (e-move
        !           374:                                                '($ _nilatom+0x1400)
        !           375:                                                temp-reg)
        !           376:                                      (e-write3 'lea
        !           377:                                                `(% 0 ,temp-areg ,temp-reg)
        !           378:                                                temp-areg)
        !           379:                                      (e-move
        !           380:                                                temp-areg
        !           381:                                                (e-cvt g-loc)))
        !           382:                             else ; must convert the hard way
        !           383:                                  (e-call-qnewint)
        !           384:                                  (d-clearreg)
        !           385:                                  (if (not (eq g-loc 'reg))
        !           386:                                      then (d-move 'reg g-loc)))
        !           387:                         ; result is always non nil
        !           388:                         (if (car g-cc) then (e-goto (car g-cc))))
        !           389:        elseif g-cc
        !           390:             ; we dont care about the value, just whether it nil
        !           391:           then (if (eq type 'lisp)
        !           392:                    then #+for-vax
        !           393:                         (e-tst `(0 ,vect-addr ,index-addr))
        !           394:                         #+for-68k
        !           395:                         (progn
        !           396:                             (e-move index-addr temp-reg)
        !           397:                             (e-write3 'asll '($ 2) temp-reg)
        !           398:                             (e-add vect-addr temp-reg)
        !           399:                             (e-move temp-reg temp-areg)
        !           400:                             (e-cmpnil `(0 ,temp-areg)))
        !           401:                         (d-handlecc)
        !           402:                    else ; if fixnum, then it is always true
        !           403:                         (if (car g-cc) then (e-goto (car g-cc)))))
        !           404:        (d-vectorindexcode)))
        !           405: 
        !           406: ;--- d-vectorindexcode :: put out code to call the vector range error.
        !           407: ; At this point the vector is in r0, the index an immediate fixnum in r5
        !           408: ; we call the function int:vector-range-error with two arguments, the
        !           409: ; vector and the index.
        !           410: ;
        !           411: (defun d-vectorindexcode ()
        !           412:    (if (null g-didvectorcode)
        !           413:       then (let ((afterlab (d-genlab)))
        !           414:              (e-goto afterlab)
        !           415:              (e-label 'vecindexerr)
        !           416:              (d-move #+for-vax 'r0 #+for-68k 'a0 'stack)
        !           417:              (e-call-qnewint)
        !           418:              (d-move 'reg 'stack)
        !           419:              (d-calltran 'int:vector-range-error 2)
        !           420:              ; never returns
        !           421:              (e-label afterlab))
        !           422:           (setq g-didvectorcode t)))
        !           423: 
        !           424: 
        !           425: ;------------------------ vector access functions
        !           426: 
        !           427: ;--- cc-vectorp :: check for vectorness
        !           428: ;
        !           429: (defun cc-vectorp nil
        !           430:   (d-typesimp (cadr v-form) #.(immed-const 18)))
        !           431: 
        !           432: ;--- cc-vectorip :: check for vectoriness
        !           433: ;
        !           434: (defun cc-vectorip nil
        !           435:   (d-typesimp (cadr v-form) #.(immed-const 19)))
        !           436: 
        !           437: ;--- c-vsize :: extract vsize
        !           438: ;
        !           439: (defun c-vsize nil
        !           440:    (d-vectorsize (cadr v-form) '2))
        !           441: 
        !           442: (defun c-vsize-byte nil
        !           443:    (d-vectorsize (cadr v-form) '0))
        !           444: 
        !           445: (defun c-vsize-word nil
        !           446:    (d-vectorsize (cadr v-form) '1))
        !           447: 
        !           448: (defun d-vectorsize (form shift)
        !           449:    (let ((g-loc #+for-vax 'reg #+for-68k 'a0)
        !           450:         g-cc
        !           451:         g-ret)
        !           452:        (d-exp form))
        !           453:    ; get size into `fixnum-reg' for fixnum boxing
        !           454:    (if (zerop shift)
        !           455:        then (e-move '(-8 #+for-vax r0 #+for-68k a0) '#.fixnum-reg)
        !           456:        else #+for-vax
        !           457:            (e-write4 'ashl (concat '$- shift) '(-8 r0) '#.fixnum-reg)
        !           458:            #+for-68k
        !           459:            (progn
        !           460:                (e-move '(-8 a0) '#.fixnum-reg)
        !           461:                (e-write3 'asrl `($ ,shift) '#.fixnum-reg)))
        !           462:    (e-call-qnewint))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.