home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / vector.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  15.1 KB  |  484 lines
  1. (include-if (null (get 'chead 'version)) "../chead.l")
  2. (Liszt-file vector
  3.    "$Header: vector.l,v 1.12 87/12/15 17:10:04 sklower 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 #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
  53.      (val-reg #+(or for-vax for-tahoe) 'r1 #+for-68k 'd1)
  54.      (index-reg '#.fixnum-reg)
  55.      (temp-reg #+(or for-vax for-tahoe) 'r4 #+for-68k 'd0)
  56.      (temp-areg #+(or for-vax for-tahoe) '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.              #+(or for-vax for-tahoe)
  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 #+(or for-vax for-tahoe) '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-tahoe
  148.             (e-write4 'shar (concat '$ size)
  149.                   `(-8 ,vect-addr) temp-reg)
  150.         #+for-68k
  151.         (progn
  152.             (e-move `(-8 ,vect-addr) temp-reg)
  153.             (e-write3 'asrl `($ ,size) temp-reg))
  154.         (e-cmp index-addr temp-reg)
  155.         (d-clearreg temp-reg))
  156.        ;; size is the number of objects, the index is 0 based so
  157.        ;; it must be less than the vector size
  158.        (e-write2 #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi oklab)
  159.        (e-write2 'jmp 'vecindexerr)
  160.        (e-label oklab)
  161.  
  162.        (if fetchval
  163.        then ; unstack the value to store...
  164.         (e-move (e-cvt 'unstack) val-reg)
  165.         (setq vect-val val-reg))
  166.  
  167.        ;; if we get here then the access is in bounds
  168.        (if (eq type 'lisp)
  169.        then #+(or for-vax for-tahoe)
  170.         (e-move vect-val `(0 ,vect-addr ,index-addr))
  171.         #+for-68k
  172.         (progn
  173.             (e-move index-addr temp-reg)
  174.             (e-write3 'asll '($ 2) temp-reg)
  175.             (e-add vect-addr temp-reg)
  176.             (e-move temp-reg temp-areg)
  177.             (e-move vect-val `(0 ,temp-areg)))
  178.         (if g-loc (e-move vect-val (e-cvt g-loc)))
  179.         (if g-cc then (d-handlecc))
  180.        else (setq temp (cadr (assq type '((byte movb)
  181.                           (word movw)
  182.                           (long movl)))))
  183.         #+(or for-vax for-tahoe)
  184.         (e-write3 temp vect-val `(0 ,vect-addr ,index-addr))
  185.         #+for-68k
  186.         (progn
  187.             (e-move index-addr temp-reg)
  188.             (caseq type
  189.             (word (e-write3 'asll '($ 1) temp-reg))
  190.             (long (e-write3 'asll '($ 2) temp-reg)))
  191.             (e-write3 'lea `(% 0 ,vec-reg ,temp-reg) temp-areg)
  192.             (if (eq type 'long)
  193.             then (e-write3 temp vect-val `(0 ,temp-areg))
  194.             else (e-move vect-val 'd1)
  195.                  (e-write3 temp 'd1 `(0 ,temp-areg))))
  196.         (if g-loc
  197.             then (if (eq type 'byte)
  198.                  then ; all bytes values are within the fixnum
  199.                   ; range, we convert them to immediate
  200.                   ; fixum with ease.
  201.                   #+for-vax
  202.                   (progn
  203.                       (e-write4 'ashl '($ 2)
  204.                         index-reg index-reg)
  205.                       (e-write3 'movab
  206.                         `(5120 ,index-reg)
  207.                         (e-cvt g-loc)))
  208.                   #+for-tahoe
  209.                   (progn
  210.                       (e-write4 'shal '($ 2)
  211.                         index-reg index-reg)
  212.                       (e-write3 'movab
  213.                         `(5120 ,index-reg)
  214.                         (e-cvt g-loc)))
  215.                   #+for-68k
  216.                   (progn
  217.                       (e-move index-reg temp-reg)
  218.                       (e-write3 'asll '($ 2) temp-reg)
  219.                       (e-move temp-reg temp-areg)
  220.                       (e-move
  221.                         (e-cvt '(fixnum 0))
  222.                         temp-reg)
  223.                       (e-write3 'lea
  224.                         `(% 0 ,temp-areg ,temp-reg)
  225.                         temp-areg)
  226.                       (e-move
  227.                         temp-areg
  228.                         (e-cvt g-loc)))
  229.                  else ; must convert the hard way
  230.                   (e-call-qnewint)
  231.                   (d-clearreg)
  232.                   (if (not (eq g-loc 'reg))
  233.                       then (d-move 'reg g-loc)))
  234.              ; result is always non nil
  235.              (if (car g-cc) then (e-goto (car g-cc)))
  236.          elseif (car g-cc) then (e-goto (car g-cc))))
  237.        (d-vectorindexcode)))
  238.  
  239. ;--- d-vref :: handle all types of vref's
  240. (defun d-vref (type)
  241.    ;;  Generic vector reference.  Type is either 'lisp', 'byte', 'word',
  242.    ;; or 'long'.
  243.    (let ((vect (cadr v-form))
  244.      (index (caddr v-form))
  245.      (vect-addr) (index-addr) (temp) (size)
  246.      (vec-reg #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
  247.      (index-reg '#.fixnum-reg)
  248.      (temp-reg #+(or for-vax for-tahoe) 'r4 #+for-68k 'd0)
  249.      (temp-areg #+(or for-vax for-tahoe) 'rX #+for-68k 'a1)
  250.      (oklab (d-genlab))
  251.      (needlowcheck t))  ; t if must check lower index bounds
  252.  
  253.        #+for-68k (d-regused '#.fixnum-reg)
  254.        (makecomment `(doing vec ref type ,type))
  255.        (if (fixp index)
  256.        then (if (<& index 0)
  257.             then (comp-err "vector index less than 0 " v-form))
  258.         (setq needlowcheck nil))
  259.  
  260.        (if (setq index-addr (d-simple index))
  261.        then (let ((g-loc vec-reg) g-cc g-ret)
  262.             (d-exp vect))
  263.         (setq vect-addr vec-reg)    ; the vector op is in vec-reg
  264.         ; we really want the cdr of index (the actual number).
  265.         ; if we can do that simply, great.  otherwise we
  266.         ; bring the index into index-reg and then do the cdr ourselves
  267.         (if (setq temp (d-simple `(cdr ,index)))
  268.             then (d-move temp index-reg)
  269.             else (d-move index-addr index-reg)
  270.              #+(or for-vax for-tahoe)
  271.              (e-move `(0 ,index-reg) index-reg)
  272.              #+for-68k
  273.              (progn
  274.                  (e-move index-reg 'a5)
  275.                  (e-move '(0 a5) index-reg)))
  276.         (setq index-addr index-reg)
  277.        else ; the index isn't computable simply, so we must
  278.         ; stack the vector location to keep it safe
  279.         (let ((g-loc 'stack) g-cc g-ret)
  280.             (d-exp vect))
  281.         (push nil g-locs)
  282.         (incr g-loccnt)
  283.         ; compute index's value into index-reg
  284.         (d-fixnumexp index)
  285.         ; now put vector address into vec-reg
  286.         (d-move 'unstack vec-reg)
  287.         (decr g-loccnt)
  288.         (pop g-locs)
  289.         (setq vect-addr vec-reg
  290.               index-addr index-reg)
  291.         ; must be sure that the cc's reflect the value of index-reg
  292.         (e-tst index-reg))
  293.        
  294.        ; at this point, vect-addr (always vec-reg) contains the location of
  295.        ; the start of the vector,  index-addr (always index-reg) contains
  296.        ; the index value.  the condition codes reflect the value of
  297.        ; the index
  298.        ; First we insure that the index is non negative
  299.        ; test must use a jmp in case the object file is large
  300.        (if needlowcheck
  301.        then (e-write2 #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl oklab)
  302.         (e-write2 'jmp 'vecindexerr)
  303.         (e-label oklab)
  304.         (setq oklab (d-genlab)))
  305.  
  306.        ; now, we compare against the size of the vector
  307.        ; the size of the vector is in bytes, we may want to shift this
  308.        ; to reflect the size in words or longwords, depending on the
  309.        ; type of reference
  310.        (if (eq type 'byte)
  311.        then ; can compare right away
  312.         (e-cmp index-addr `(-8 ,vect-addr))
  313.        else ; shift size into temp-reg
  314.         (setq size (if (eq type 'word) then 1 else 2))
  315.         #+for-vax
  316.         (e-write4 'ashl (concat '$- size) `(-8 ,vect-addr) temp-reg)
  317.         #+for-tahoe
  318.         (e-write4 'shar (concat '$ size) `(-8 ,vect-addr) temp-reg)
  319.         #+for-68k
  320.         (progn
  321.             (e-move `(-8 ,vect-addr) temp-reg)
  322.             (e-write3 'asrl `($ ,size) temp-reg))
  323.         (e-cmp index-addr temp-reg)
  324.         (d-clearreg temp-reg))
  325.        ; size is the number of objects, the index is 0 based so
  326.        ; it must be less than the vector size
  327.        (e-write2 #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi oklab)
  328.        (e-write2 'jmp 'vecindexerr)
  329.        (e-label oklab)
  330.  
  331.        ;; if we get here then the access is in bounds
  332.        (if g-loc
  333.        then ; we care about the value.
  334.         ; if the value is one of the fixnum types, then we
  335.         ; move the value to index-reg so it can be fixnum converted
  336.         (if (eq type 'lisp)
  337.             then #+(or for-vax for-tahoe)
  338.              (e-move `(0 ,vect-addr ,index-addr)
  339.                    (e-cvt g-loc))
  340.              #+for-68k
  341.              (progn
  342.                  (e-move index-addr temp-reg)
  343.                  (e-write3 'asll '($ 2) temp-reg)
  344.                  (e-add vect-addr temp-reg)
  345.                  (e-move temp-reg temp-areg)
  346.                  (e-move `(0 ,temp-areg) (e-cvt g-loc)))
  347.              (if g-cc then (d-handlecc))
  348.             else #+(or for-vax for-tahoe)
  349.              (progn
  350.                  (setq temp (cadr (assq type '((byte cvtbl)
  351.                                (word cvtwl)
  352.                                (long movl)))))
  353.                  (e-write3 temp
  354.                        `(0 ,vect-addr ,index-addr)
  355.                        index-reg))
  356.              #+for-68k
  357.              (progn
  358.                  (setq temp
  359.                    (cadr (assq type '((byte movb)
  360.                               (word movw)
  361.                               (long movl)))))
  362.                  (caseq type
  363.                     (word (e-write3 'asll '($ 1) index-reg))
  364.                     (long (e-write3 'asll '($ 2) index-reg)))
  365.                  (e-write3 'lea `(% 0 ,vec-reg ,index-reg)
  366.                        temp-areg)
  367.                  (if (memq type '(byte word))
  368.                  then (e-write2 'clrl index-reg))
  369.                  (e-write3 temp `(0 ,temp-areg) index-reg))
  370.              (if (eq type 'byte)
  371.                  then ; all bytes values are within the fixnum
  372.                   ; range, we convert them to immediate
  373.                   ; fixum with ease.
  374.                   #+for-vax
  375.                   (progn
  376.                       (e-write4 'ashl '($ 2)
  377.                         index-reg index-reg)
  378.                       (e-write3 'movab
  379.                         `(5120 ,index-reg)
  380.                         (e-cvt g-loc)))
  381.                   #+for-tahoe
  382.                   (progn
  383.                       (e-write4 'shal '($ 2)
  384.                         index-reg index-reg)
  385.                       (e-write3 'movab
  386.                         `(5120 ,index-reg)
  387.                         (e-cvt g-loc)))
  388.                   #+for-68k
  389.                   (progn
  390.                       (e-write3 'asll '($ 2) index-reg)
  391.                       (e-move index-reg temp-areg)
  392.                       (e-move
  393.                         '($ _nilatom+0x1400)
  394.                         temp-reg)
  395.                       (e-write3 'lea
  396.                         `(% 0 ,temp-areg ,temp-reg)
  397.                         temp-areg)
  398.                       (e-move
  399.                         temp-areg
  400.                         (e-cvt g-loc)))
  401.                  else ; must convert the hard way
  402.                   (e-call-qnewint)
  403.                   (d-clearreg)
  404.                   (if (not (eq g-loc 'reg))
  405.                       then (d-move 'reg g-loc)))
  406.              ; result is always non nil
  407.              (if (car g-cc) then (e-goto (car g-cc))))
  408.     elseif g-cc
  409.          ; we dont care about the value, just whether it nil
  410.        then (if (eq type 'lisp)
  411.             then #+(or for-vax for-tahoe)
  412.              (e-tst `(0 ,vect-addr ,index-addr))
  413.              #+for-68k
  414.              (progn
  415.                  (e-move index-addr temp-reg)
  416.                  (e-write3 'asll '($ 2) temp-reg)
  417.                  (e-add vect-addr temp-reg)
  418.                  (e-move temp-reg temp-areg)
  419.                  (e-cmpnil `(0 ,temp-areg)))
  420.              (d-handlecc)
  421.             else ; if fixnum, then it is always true
  422.              (if (car g-cc) then (e-goto (car g-cc)))))
  423.        (d-vectorindexcode)))
  424.  
  425. ;--- d-vectorindexcode :: put out code to call the vector range error.
  426. ; At this point the vector is in r0, the index an immediate fixnum in r5
  427. ; we call the function int:vector-range-error with two arguments, the
  428. ; vector and the index.
  429. ;
  430. (defun d-vectorindexcode ()
  431.    (if (null g-didvectorcode)
  432.       then (let ((afterlab (d-genlab)))
  433.           (e-goto afterlab)
  434.           (e-label 'vecindexerr)
  435.           (d-move #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0 'stack)
  436.           (e-call-qnewint)
  437.           (d-move 'reg 'stack)
  438.           (d-calltran 'int:vector-range-error 2)
  439.           ; never returns
  440.           (e-label afterlab))
  441.        (setq g-didvectorcode t)))
  442.  
  443.  
  444. ;------------------------ vector access functions
  445.  
  446. ;--- cc-vectorp :: check for vectorness
  447. ;
  448. (defun cc-vectorp nil
  449.   (d-typesimp (cadr v-form) #.(immed-const 18)))
  450.  
  451. ;--- cc-vectorip :: check for vectoriness
  452. ;
  453. (defun cc-vectorip nil
  454.   (d-typesimp (cadr v-form) #.(immed-const 19)))
  455.  
  456. ;--- c-vsize :: extract vsize
  457. ;
  458. (defun c-vsize nil
  459.    (d-vectorsize (cadr v-form) '2))
  460.  
  461. (defun c-vsize-byte nil
  462.    (d-vectorsize (cadr v-form) '0))
  463.  
  464. (defun c-vsize-word nil
  465.    (d-vectorsize (cadr v-form) '1))
  466.  
  467. (defun d-vectorsize (form shift)
  468.    (let ((g-loc #+(or for-vax for-tahoe) 'reg #+for-68k 'a0)
  469.      g-cc
  470.      g-ret)
  471.        (d-exp form))
  472.    ; get size into `fixnum-reg' for fixnum boxing
  473.    (if (zerop shift)
  474.        then (e-move '(-8 #+(or for-vax for-tahoe) r0 #+for-68k a0) '#.fixnum-reg)
  475.        else #+for-vax
  476.         (e-write4 'ashl (concat '$- shift) '(-8 r0) '#.fixnum-reg)
  477.         #+for-tahoe
  478.         (e-write4 'shar (concat '$ shift) '(-8 r0) '#.fixnum-reg)
  479.         #+for-68k
  480.         (progn
  481.         (e-move '(-8 a0) '#.fixnum-reg)
  482.         (e-write3 'asrl `($ ,shift) '#.fixnum-reg)))
  483.    (e-call-qnewint))
  484.