Changeset 13897


Ignore:
Timestamp:
Jun 28, 2010, 10:43:56 PM (9 years ago)
Author:
gb
Message:

arm-asm.lisp, arm-lap.lisp: drain-constant-pool. At least slightly
better than nothing. Check to make sure that :mem12 pc-relative label
references are within 12 bits of their target.

arm-backend: uncomment code to require arm-vinsns

arm-disassemble: hook up to DISASSEMBLE.

arm-vinsns: in REQUIRE-U32, get subtag from the right place.

arm2.lisp: assume that .SPprogvsave sets up an unwind-protect.

arm-bignum.lisp: %ADD-THE-CARRRY is indeed silly.

arm-misc.lisp: unscramble %UNLOCK-GC-LOCK, don't clobber address
in %PTR-STORE-FIXNUM-CONDITIONAL.

arm-utils.lisp: GC.

l1-boot-1.lisp: add ARM to PLATFORM-CPU-NAMES.

l1-boot-2.lisp: require disassembler, lapmacros files on ARM.

l1-boot-3.lisp: comment out error-callback activation on ARM.

l1-init.lisp: set *SAVE-SOURCE-LOCATIONS* to NIL on ARM for now. (More code
to step through/debug, and not short of that.)

version.lisp: don't say "arm-cross" if #+arm-target.

arm-gc.c: get a lot of this working, seemingly.

arm-macros.s: fix skip_stack_vector.

arm-spentry.s: get PROGV support working.

gc-common.c: check static-cons freelist only if GCDebug.

linuxarm/Makefile: enable GC integrity checks.

lisp-debug.c: start to support 'describe exception" for ARM.

Location:
branches/arm
Files:
20 edited

Legend:

Unmodified
Added
Removed
  • branches/arm/compiler/ARM/arm-asm.lisp

    r13892 r13897  
    4545(defvar *lap-labels* ())
    4646(defvar *called-subprim-jmp-labels* ())
     47(defvar *last-constant-pool-origin* ())
     48
    4749
    4850
     
    168170  `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'%encode-arm-operand-type operand-type-names) ))
    169171
     172
     173
    170174(defparameter *arm-instruction-table*
    171175  (vector
     
    437441      (#x01700010 . #x0ff00090))
    438442     ())
     443
    439444   (define-arm-instruction cmns (:rd :shifter)
    440445     #x01700000
     
    443448      (#x01700010 . #x0ff00090))
    444449     ())
     450   
    445451
    446452   ;; (ba subprim-name) -> (mov pc ($ subprim-address))
     
    13731379  (let* ((start 0))
    13741380    (ccl::do-dll-nodes (element seg start)
    1375     (incf start (instruction-element-size element)))))
    1376 
     1381      (incf start (instruction-element-size element)))))
     1382
     1383(defun element-sizes-since (seg first)
     1384  (let* ((n 0))
     1385    (do* ((curr (or first (ccl::dll-node-succ seg)) (ccl::dll-node-succ curr)))
     1386         ((eq curr seg) n)
     1387      (incf n (instruction-element-size curr)))))
     1388
     1389
     1390;;; It's better to do this naively than to not do it at all
     1391(defun drain-constant-pool (primary constant-pool)
     1392  (let* ((n-constant-bytes (count-element-sizes constant-pool)))
     1393    (declare (fixnum n-constant-bytes))
     1394    (when (> n-constant-bytes 0)
     1395      (when (> (+ n-constant-bytes (element-sizes-since primary *last-constant-pool-origin*)) 4000) ; some slack here
     1396        ;; Jump around an embedded constant pool.  We might be following
     1397        ;; some flavor of a jump with an unreachable one, or sticking
     1398        ;; some stuff in the middle of a jump table, or something.
     1399        ;; LAP functions that have jump tables aren't likely to be
     1400        ;; big enough to need to worry about this; if the compiler
     1401        ;; generates jump tables or other span-dependent things, it'll
     1402        ;; have to be careful about how it does so.       
     1403        (multiple-value-bind (first last) (ccl::detach-dll-nodes constant-pool)
     1404          (let* ((target-name (gensym))
     1405                 (origin (make-lap-instruction nil))
     1406                 (offset (make-lap-instruction nil))
     1407                 (pool-count (make-lap-instruction nil))
     1408                 (offset-label (make-lap-label (gensym))))
     1409            (assemble-instruction primary `(b ,target-name))
     1410            (setf (lap-instruction-opcode origin) 0)
     1411            (ccl::append-dll-node origin primary)
     1412            (setq *last-constant-pool-origin* origin)
     1413            (setf (lap-instruction-opcode offset) 0)
     1414            (ccl::append-dll-node offset primary)
     1415            (setf (lap-instruction-opcode pool-count)
     1416                  (ash n-constant-bytes (- arm::word-shift)))
     1417            (ccl::append-dll-node pool-count primary)
     1418            (ccl::insert-dll-node-after first pool-count last)
     1419            (push (cons offset :offset) (lap-label-refs offset-label))
     1420            (emit-lap-label primary (lap-label-name offset-label))
     1421            (emit-lap-label primary target-name)))))))
     1422           
     1423   
     1424 
    13771425(defun arm-finalize (primary constant-pool)
    13781426  (do-lap-labels (lab)
    13791427    (loop
    1380       (when (dolist (ref (lap-label-refs lab) t)
    1381               (when (eq lab (lap-instruction-succ (car ref)))
     1428      (when (dolist (ref (lap-label-refs lab) t)             
     1429              (when (and (eq :b (cdr ref))
     1430                         (eq lab (lap-instruction-succ (car ref))))
    13821431                (ccl::remove-dll-node (car ref))
    13831432                (setf (lap-label-refs lab)
     
    14191468                   (set-field-value insn (byte 1 23) 1)
    14201469                   (setq diff-in-bytes (- diff-in-bytes)))
     1470                 (when (> (integer-length diff-in-bytes) 12)
     1471                   (error "PC-relative displacement can't be encoded."))
    14211472                 (set-field-value insn (byte 12 0) diff-in-bytes))
     1473                (:offset
     1474                 (setf (lap-instruction-opcode insn)
     1475                       (1+ (ash (lap-instruction-address insn) (- arm::word-shift)))))
    14221476                (t
    14231477                 (error "Label type ~s invalid or not yet supported."
  • branches/arm/compiler/ARM/arm-backend.lisp

    r13759 r13897  
    314314(pushnew *arm-backend* *known-backends* :key #'backend-name)
    315315
    316 #+notyet
    317316(require "ARM-VINSNS")
    318317
  • branches/arm/compiler/ARM/arm-disassemble.lisp

    r13889 r13897  
    428428                       
    429429             
    430        
     430(defun arm-xdisassemble (function)
     431  (disassemble-arm-xfunction function *standard-output*))
  • branches/arm/compiler/ARM/arm-lap.lisp

    r13789 r13897  
    6666    (with-dll-node-freelist (constant-pool arm::*lap-instruction-freelist*)
    6767      (let* ((arm::*lap-labels* ())
     68             (arm::*last-constant-pool-origin* ())
    6869             (name-cell (list name))
    6970             (arm::*arm-constants* ())
  • branches/arm/compiler/ARM/arm-vinsns.lisp

    r13892 r13897  
    941941  (and temp src (:$ arm::tagmask))
    942942  (cmp temp (:$ arm::tag-misc))
    943   (ldrbeq temp (:@ src (:$ arm::misc-data-offset)))
     943  (ldrbeq temp (:@ src (:$ arm::misc-subtag-offset)))
    944944  (cmp temp (:$ arm::subtag-bignum))
    945945  (bne :bad-if-ne)
  • branches/arm/compiler/ARM/arm2.lisp

    r13889 r13897  
    437437                   (let* ((sections (vector code data))
    438438                          (arm::*lap-labels* nil)
     439                          (arm::*last-constant-pool-origin* nil)
    439440                          (arm::*called-subprim-jmp-labels* nil)
    440441                          debug-info)
     
    47584759            (setf (vinsn-label-info v) (arm::emit-lap-label current v)))
    47594760          (arm2-expand-note current id)))
    4760       (setq current (arm2-expand-vinsn v current sections))))
     4761      (progn
     4762        (setq current (arm2-expand-vinsn v current sections))
     4763        (arm::drain-constant-pool (svref sections 0) (svref sections 1)))))
    47614764  ;;; This doesn't have too much to do with anything else that's
    47624765  ;;; going on here, but it needs to happen before the lregs
     
    48524855                     (if (eval-predicate (car f))
    48534856                       (dolist (subform (cdr f))
    4854                            (expand-form subform))))))))
     4857                         (expand-form subform))))))))
    48554858      (declare (dynamic-extent #'expand-form #'parse-operand-form #'expand-insn-form #'eval-predicate))
    48564859                                        ;(format t "~& vinsn = ~s" vinsn)
     
    77507753         (old-stack (arm2-encode-stack)))
    77517754    (arm2-two-targeted-reg-forms seg symbols ($ arm::arg_y) values ($ arm::arg_z))
    7752     (! progvsave)
     7755    (! progvsave)                       ;creates an unwind-protect
    77537756    (arm2-open-undo $undostkblk)
    7754     (! mkunwind)
    77557757    (! non-barrier-jump (aref *backend-labels* cleanup-label))
    77567758    (-> protform-label)
  • branches/arm/level-0/ARM/arm-bignum.lisp

    r13889 r13897  
    146146  (box-fixnum arg_z imm0)
    147147  (bx lr))
     148
     149; this is silly
     150(defarmlapfunction %add-the-carry ((b-h arg_x) (b-l arg_y) (carry-in arg_z))
     151  (let ((a imm0)
     152        (b imm1)
     153        (c imm2))   
     154    (compose-digit b b-h b-l)
     155    (unbox-fixnum c carry-in)
     156    (add b c b)
     157    (digit-h temp0 b)
     158    (digit-l temp1 b)
     159    (vpush1 temp0)
     160    (vpush1 temp1)
     161    (add temp0 vsp '2)
     162    (set-nargs 2)
     163    (ba .SPvalues)))
    148164
    149165
  • branches/arm/level-0/ARM/arm-misc.lisp

    r13889 r13897  
    402402  (mov arg_x ($ 0))
    403403  (ldrex arg_y (:@ imm1))
    404   (cmp arg_y (:$ -1))
     404  (cmp arg_y '-1)
    405405  (moveq arg_x arg_y)
    406   (cmp arg_y (:$ 0))
    407   (sub arg_z arg_y (:$ 1))
    408   (addlt arg_z arg_y '1)
     406  (subgt arg_z arg_y '1)
     407  (addle arg_z arg_y '1)
    409408  (strex imm0 arg_z (:@ imm1))
    410409  (cmp imm0 ($ 0))
    411410  (bne @again)
    412   (cmp arg_x (:$ 0))
     411  (cmp arg_x '0)
    413412  (bxeq lr)
    414413  (mov imm0 (:$ arch::gc-trap-function-immediate-gc))
     
    513512
    514513(defarmlapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
    515   (let ((address imm0)
     514  (let ((address imm2)
    516515        (actual-oldval imm1))
    517516    (macptr-ptr address ptr)
  • branches/arm/level-0/ARM/arm-utils.lisp

    r13892 r13897  
    311311
    312312
     313(defarmlapfunction gc ()
     314  (check-nargs 0)
     315  (mov imm0 (:$ arch::gc-trap-function-gc))
     316  (uuo-gc-trap (:? al))
     317  (mov arg_z 'nil)
     318  (bx lr))
     319
    313320#+notyet                                ;trap encoding
    314321(progn
    315 (defarmlapfunction gc ()
    316   (check-nargs 0)
    317   (li imm0 arch::gc-trap-function-gc)
    318   (trlgei allocptr 0)
    319   (li arg_z (target-nil-value))
    320   (bx lr))
     322
    321323
    322324
  • branches/arm/level-1/l1-boot-1.lisp

    r13067 r13897  
    4747  `((,platform-cpu-ppc . :ppc)
    4848    (,platform-cpu-sparc . :sparc)
    49     (,platform-cpu-x86 . :x86)))
     49    (,platform-cpu-x86 . :x86)
     50    (,platform-cpu-arm . :arm)))
    5051
    5152(defun host-platform ()
  • branches/arm/level-1/l1-boot-2.lisp

    r13847 r13897  
    300300        (bin-load "x86-watch"))
    301301
     302      #+arm-target
     303      (progn
     304        (bin-load-provide "ARM-DISASSEMBLE" "arm-disassemble")
     305        (bin-load-provide "ARM-LAPMACROS" "arm-lapmacros"))
    302306
    303307      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
  • branches/arm/level-1/l1-boot-3.lisp

    r13067 r13897  
    2626)
    2727
     28#+arm-target
     29(eval-when (:compile-toplevel)
     30  (warn "Remember to reenable error callbacks."))
    2831(set-periodic-task-interval .33)
    29 (setq cmain xcmain)
    30 (setq %err-disp %xerr-disp)
     32#-arm-target (setq cmain xcmain)
     33#-arm-target (setq %err-disp %xerr-disp)
    3134
    3235;;;end of l1-boot-3.lisp
  • branches/arm/level-1/l1-init.lisp

    r13529 r13897  
    266266(defparameter *save-definitions* nil)
    267267(defparameter *save-local-symbols* t)
    268 (defparameter *save-source-locations* T
     268(defparameter *save-source-locations* #+arm-target nil #-arm-target  T
    269269  "Controls whether source location information is saved, both for definitions (names) and
    270270in function objects.
  • branches/arm/level-1/version.lisp

    r13704 r13897  
    2020(defparameter *openmcl-major-version* 1)
    2121(defparameter *openmcl-minor-version* 5)
    22 (defparameter *openmcl-revision* "ARM-cross")
     22(defparameter *openmcl-revision* #+arm-target nil #-arm-target "ARM-cross")
    2323;;; May be set by xload-level-0
    2424(defvar *openmcl-svn-revision* nil)
  • branches/arm/lisp-kernel/arm-gc.c

    r13737 r13897  
    161161      break;
    162162
    163     case AREA_TSTACK:
    164       {
    165         LispObj *current, *next,
    166                 *start = (LispObj *) a->active,
    167                 *end = start,
    168                 *limit = (LispObj *) a->high;
    169                  
    170         for (current = start;
    171              end != limit;
    172              current = next) {
    173           next = ptr_from_lispobj(*current);
    174           end = ((next >= start) && (next < limit)) ? next : limit;
    175           if (current[1] == 0) {
    176             check_range(current+2, end, true);
    177           }
    178         }
    179       }
    180       break;
    181163    }
    182164    a = a->succ;
     
    937919}
    938920
    939 
    940 /* Mark a tstack area */
    941921void
    942922mark_tstack_area(area *a)
    943923{
    944   LispObj
    945     *current,
    946     *next,
    947     *start = (LispObj *) (a->active),
    948     *end = start,
    949     *limit = (LispObj *) (a->high);
    950 
    951   for (current = start;
    952        end != limit;
    953        current = next) {
    954     next = (LispObj *) ptr_from_lispobj(*current);
    955     end = ((next >= start) && (next < limit)) ? next : limit;
    956     if (current[1] == 0) {
    957       mark_simple_area_range(current+2, end);
    958     }
    959   }
    960924}
    961925
     
    996960mark_cstack_area(area *a)
    997961{
    998   BytePtr
    999     current,
    1000     next,
    1001     limit = a->high,
    1002     low = a->low;
    1003 
    1004   for (current = a->active; (current >= low) && (current < limit); current = next) {
    1005     next = *((BytePtr *)current);
    1006 #if 0
    1007     if (next < current) {
    1008       Bug(NULL, "Child stack frame older than parent");
    1009     }
    1010 #endif
    1011     if (next == NULL) break;
    1012     if (((next - current) == sizeof(lisp_frame)) &&
    1013         (((((lisp_frame *)current)->savefn) == 0) ||
    1014          (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
    1015       /* mark fn, then saved lr */
    1016       mark_root(((lisp_frame *)current)->savefn);
    1017       mark_pc_root(((lisp_frame *)current)->savelr);
     962  LispObj *current = (LispObj *)(a->active)
     963    , *limit = (LispObj*)(a->high), header;
     964  lisp_frame *frame;
     965
     966  while(current < limit) {
     967    header = *current;
     968
     969    if (header == lisp_frame_marker) {
     970      frame = (lisp_frame *)current;
     971     
     972      mark_root(frame->savevsp); /* likely a fixnum */
     973      mark_root(frame->savefn);
     974      mark_pc_root(frame->savelr);
     975      current += sizeof(lisp_frame)/sizeof(LispObj);
     976    } else if (header == stack_alloc_marker) {
     977      current += 2;
     978    } else if (nodeheader_tag_p(fulltag_of(header))) {
     979      natural elements = header_element_count(header);
     980
     981      current++;
     982      while(elements--) {
     983        mark_root(*current++);
     984      }
     985      if (((natural)current) & sizeof(natural)) {
     986        current++;
     987      }
     988    } else if (immheader_tag_p(fulltag_of(header))) {
     989      current=(LispObj *)skip_over_ivector((natural)current,header);
    1018990    } else {
    1019       /* Clear low 2 bits of "next", just in case */
    1020       next = (BytePtr) (((natural)next) & ~3);
     991      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
    1021992    }
    1022993  }
     
    10331004  int r;
    10341005  /* registers >= fn should be tagged and marked as roots.
    1035      the PC, LR, loc_pc, and CTR should be treated as "pc_locatives".
     1006     the PC, and LR should be treated as "pc_locatives".
    10361007
    10371008     In general, marking a locative is more expensive than marking
     
    11141085  pagelet = dnode >> 5;
    11151086  nbits = dnode & 0x1f;
    1116   near_bits = ((unsigned short *)GCdynamic_markbits)[dnode>>4];
     1087  /* On little-endian ARM, we have to flip the low bit of dnode>>4 to
     1088     get the near_bits from the appropriate half-word. */
     1089  near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1];
    11171090
    11181091  if (nbits < 16) {
     
    11391112        new -= one_bits(near_bits >> 8);
    11401113      }
    1141       return (new -  one_bits(near_bits & 0xff));
     1114      return (new - one_bits(near_bits & 0xff));
    11421115    }
    11431116  }
     
    12201193      } else {
    12211194        p++;
     1195        if (header_subtag(node) == subtag_function) {
     1196          update_locref(p);
     1197          p++;
     1198          nwords--;
     1199        }
    12221200        while(nwords--) {
    12231201          update_noderef(p);
     
    12381216
    12391217
    1240 
    1241 
    1242 /* Forward a tstack area */
    12431218void
    12441219forward_tstack_area(area *a)
    12451220{
    1246   LispObj
    1247     *current,
    1248     *next,
    1249     *start = (LispObj *) a->active,
    1250     *end = start,
    1251     *limit = (LispObj *) (a->high);
    1252 
    1253   for (current = start;
    1254        end != limit;
    1255        current = next) {
    1256     next = ptr_from_lispobj(*current);
    1257     end = ((next >= start) && (next < limit)) ? next : limit;
    1258     if (current[1] == 0) {
    1259       forward_range(current+2, end);
    1260     }
    1261   }
    1262 }
     1221}
     1222
    12631223
    12641224/* Forward a vstack area */
     
    12831243forward_cstack_area(area *a)
    12841244{
    1285   BytePtr
    1286     current,
    1287     next,
    1288     limit = a->high,
    1289     low = a->low;
    1290 
    1291   for (current = a->active; (current >= low) && (current < limit); current = next) {
    1292     next = *((BytePtr *)current);
    1293     if (next == NULL) break;
    1294     if (((next - current) == sizeof(lisp_frame)) &&
    1295         (((((lisp_frame *)current)->savefn) == 0) ||
    1296          (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
    1297       update_noderef(&((lisp_frame *) current)->savefn);
    1298       update_locref(&((lisp_frame *) current)->savelr);
     1245  LispObj *current = (LispObj *)(a->active)
     1246    , *limit = (LispObj*)(a->high), header;
     1247  lisp_frame *frame;
     1248
     1249  while (current < limit) {
     1250    header = *current;
     1251
     1252    if (header == lisp_frame_marker) {
     1253      frame = (lisp_frame *)current;
     1254
     1255      update_noderef(&(frame->savefn));
     1256      update_locref(&(frame->savelr));
     1257      current += sizeof(lisp_frame)/sizeof(LispObj);
     1258    } else if (header == stack_alloc_marker) {
     1259      current += 2;
     1260    } else if (nodeheader_tag_p(fulltag_of(header))) {
     1261      natural elements = header_element_count(header);
     1262
     1263      current++;
     1264      if (header_subtag(header) == subtag_function) {
     1265        update_locref(current);
     1266        current++;
     1267        elements--;
     1268      }
     1269      while(elements--) {
     1270        update_noderef(current);
     1271        current++;
     1272      }
     1273      if (((natural)current) & sizeof(natural)) {
     1274        current++;
     1275      }
     1276    } else if (immheader_tag_p(fulltag_of(header))) {
     1277      current=(LispObj *)skip_over_ivector((natural)current,header);
     1278    } else {
     1279      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
    12991280    }
    13001281  }
     
    14401421          } else {
    14411422            *dest++ = node;
    1442             *dest++ = node_forwarding_address(*src++);
     1423            if (header_subtag(node) == subtag_function) {
     1424              *dest++ = locative_forwarding_address(*src++);
     1425            } else {
     1426              *dest++ = node_forwarding_address(*src++);
     1427            }
    14431428            while(--node_dnodes) {
    14441429              *dest++ = node_forwarding_address(*src++);
     
    16871672}
    16881673       
    1689 /* Purify references from tstack areas */
    1690 void
    1691 purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
    1692 {
    1693   LispObj
    1694     *current,
    1695     *next,
    1696     *start = (LispObj *) (a->active),
    1697     *end = start,
    1698     *limit = (LispObj *) (a->high);
    1699 
    1700   for (current = start;
    1701        end != limit;
    1702        current = next) {
    1703     next = (LispObj *) ptr_from_lispobj(*current);
    1704     end = ((next >= start) && (next < limit)) ? next : limit;
    1705     if (current[1] == 0) {
    1706       purify_range(current+2, end, low, high, to);
    1707     }
    1708   }
    1709 }
    17101674
    17111675/* Purify a vstack area */
     
    17281692purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to)
    17291693{
    1730   BytePtr
    1731     current,
    1732     next,
    1733     limit = a->high;
    1734 
    1735   for (current = a->active; current != limit; current = next) {
    1736     next = *((BytePtr *)current);
    1737     if (next == NULL) break;
    1738     if (((next - current) == sizeof(lisp_frame)) &&
    1739         (((((lisp_frame *)current)->savefn) == 0) ||
    1740          (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
    1741       purify_locref(&((lisp_frame *) current)->savelr, low, high, to);
     1694  LispObj *current = (LispObj *)(a->active)
     1695    , *limit = (LispObj*)(a->high), header;
     1696  lisp_frame *frame;
     1697
     1698
     1699  while(current < limit) {
     1700    header = *current;
     1701
     1702    if (header == lisp_frame_marker) {
     1703      frame = (lisp_frame *)current;
     1704     
     1705      copy_ivector_reference(&(frame->savevsp), low, high, to); /* likely a fixnum */
     1706      copy_ivector_reference(&(frame->savefn), low, high, to);
     1707      purify_locref(&(frame->savelr), low, high, to);
     1708      current += sizeof(lisp_frame)/sizeof(LispObj);
     1709    } else if (header == stack_alloc_marker) {
     1710      current += 2;
     1711    } else if (nodeheader_tag_p(fulltag_of(header))) {
     1712      natural elements = header_element_count(header);
     1713
     1714      current++;
     1715      if (header_subtag(header) == subtag_function) {
     1716        purify_locref(current, low, high, to);
     1717        current++;
     1718        elements--;
     1719      }
     1720      while(elements--) {
     1721        copy_ivector_reference(current, low, high, to);
     1722        current++;
     1723      }
     1724      if (((natural)current) & sizeof(natural)) {
     1725        current++;
     1726      }
     1727    } else if (immheader_tag_p(fulltag_of(header))) {
     1728      current=(LispObj *)skip_over_ivector((natural)current,header);
    17421729    } else {
    1743       /* Clear low bits of "next", just in case */
    1744       next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1));
     1730      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
    17451731    }
    17461732  }
     
    18121798  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
    18131799    switch (code) {
    1814     case AREA_TSTACK:
    1815       purify_tstack_area(next_area, low, high, target);
    1816       break;
    1817      
    18181800    case AREA_VSTACK:
    18191801      purify_vstack_area(next_area, low, high, target);
     
    19241906 
    19251907
    1926 #ifdef PPC
    19271908void
    19281909impurify_cstack_area(area *a, LispObj low, LispObj high, int delta)
    19291910{
    1930   BytePtr
    1931     current,
    1932     next,
    1933     limit = a->high;
    1934 
    1935   for (current = a->active; current != limit; current = next) {
    1936     next = *((BytePtr *)current);
    1937     if (next == NULL) break;
    1938     if (((next - current) == sizeof(lisp_frame)) &&
    1939         (((((lisp_frame *)current)->savefn) == 0) ||
    1940          (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
    1941       impurify_locref(&((lisp_frame *) current)->savelr, low, high, delta);
     1911  LispObj *current = (LispObj *)(a->active)
     1912    , *limit = (LispObj*)(a->high), header;
     1913  lisp_frame *frame;
     1914  while(current < limit) {
     1915    header = *current;
     1916
     1917    if (header == lisp_frame_marker) {
     1918      frame = (lisp_frame *)current;
     1919     
     1920      impurify_noderef(&(frame->savevsp), low, high,delta); /* likely a fixnum */
     1921      impurify_noderef(&(frame->savefn), low, high, delta);
     1922      impurify_locref(&(frame->savelr), low, high, delta);
     1923      current += sizeof(lisp_frame)/sizeof(LispObj);
     1924    } else if (header == stack_alloc_marker) {
     1925      current += 2;
     1926    } else if (nodeheader_tag_p(fulltag_of(header))) {
     1927      natural elements = header_element_count(header);
     1928
     1929      current++;
     1930      if (header_subtag(header) == subtag_function) {
     1931        impurify_locref(current, low, high, delta);
     1932        current++;
     1933        elements--;
     1934      }
     1935      while(elements--) {
     1936        impurify_noderef(current, low, high, delta);
     1937        current++;
     1938      }
     1939      if (((natural)current) & sizeof(natural)) {
     1940        current++;
     1941      }
     1942    } else if (immheader_tag_p(fulltag_of(header))) {
     1943      current=(LispObj *)skip_over_ivector((natural)current,header);
    19421944    } else {
    1943       /* Clear low bits of "next", just in case */
    1944       next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1));
    1945     }
    1946   }
    1947 }
    1948 #endif
     1945      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
     1946    }
     1947  }
     1948}
     1949
    19491950
    19501951void
     
    19521953{
    19531954  natural *regs = (natural *) xpGPRvector(xp);
    1954 
    1955 #ifdef PPC
    19561955  int r;
    1957   /* registers >= fn should be treated as roots.
    1958      The PC, LR, loc_pc, and CTR should be treated as "locatives".
     1956
     1957  /* node registers should be treated as roots.
     1958     The PC and LR should be treated as "locatives".
    19591959   */
    19601960
    1961   for (r = fn; r < 32; r++) {
     1961  for (r = arg_z; r <= fn; r++) {
    19621962    impurify_noderef((LispObj*) (&(regs[r])), low, high, delta);
    19631963  };
    19641964
    1965   impurify_locref((LispObj*) (&(regs[loc_pc])), low, high, delta);
    19661965
    19671966  impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta);
    19681967  impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta);
    1969   impurify_locref((LispObj*) (&(xpCTR(xp))), low, high, delta);
    1970 #endif
    19711968
    19721969}
     
    20242021
    20252022void
    2026 impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
    2027 {
    2028   LispObj
    2029     *current,
    2030     *next,
    2031     *start = (LispObj *) (a->active),
    2032     *end = start,
    2033     *limit = (LispObj *) (a->high);
    2034 
    2035   for (current = start;
    2036        end != limit;
    2037        current = next) {
    2038     next = (LispObj *) ptr_from_lispobj(*current);
    2039     end = ((next >= start) && (next < limit)) ? next : limit;
    2040     if (current[1] == 0) {
    2041       impurify_range(current+2, end, low, high, delta);
    2042     }
    2043   }
    2044 }
    2045 void
    20462023impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
    20472024{
     
    20662043  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
    20672044    switch (code) {
    2068     case AREA_TSTACK:
    2069       impurify_tstack_area(next_area, low, high, delta);
    2070       break;
    20712045     
    20722046    case AREA_VSTACK:
     
    20752049     
    20762050    case AREA_CSTACK:
    2077 #ifdef PPC
    20782051      impurify_cstack_area(next_area, low, high, delta);
    2079 #endif
    20802052      break;
    20812053     
  • branches/arm/lisp-kernel/arm-macros.s

    r13889 r13897  
    482482macro_label(bytes):     
    483483        __(add $1,$1,#node_size+(dnode_size-1))
     484        __(bic $1,$1,#fulltagmask)
    484485        __(add $1,$1,$3)
    485486        ')
  • branches/arm/lisp-kernel/arm-spentry.s

    r13892 r13897  
    998998
    999999_spentry(progvsave)
    1000         __(uuo_debug_trap(al))
    1001 dnl  /* Error if arg_z isn't a proper list.  That's unlikely, */
    1002 dnl  /* but it's better to check now than to crash later. */
    1003 dnl 
    1004 dnl  __(cmp arg_z,#nil_value)
    1005 dnl  __(mov arg_x,arg_z) /* fast  */
    1006 dnl  __(mov temp1,arg_z) /* slow  */
    1007 dnl  __(beq 9f)  /* Null list is proper  */
    1008 dnl 0:
    1009 dnl  __(trap_unless_list(arg_x,imm0))
    1010 dnl  __(_cdr(temp2,arg_x)) /* (null (cdr fast)) ?  */
    1011 dnl  __(cmpri(cr3,temp2,nil_value))
    1012 dnl  __(trap_unless_list(temp2,imm0,cr0))
    1013 dnl  __(_cdr(arg_x,temp2))
    1014 dnl  __(beq cr3,9f)
    1015 dnl  __(_cdr(temp1,temp1))
    1016 dnl  __(cmpr(arg_x,temp1))
    1017 dnl  __(bne 0b)
    1018 dnl  __(mov arg_y,#XIMPROPERLIST)
    1019 dnl  __(set_nargs(2))
    1020 dnl  __(b _SPksignalerr)
    1021 dnl 9: /* Whew   */
    1022 dnl 
    1023 dnl         /* Next, determine the length of arg_y.  We  */
    1024 dnl         /* know that it's a proper list.  */
    1025 dnl  __(mov imm0,#-node_size)
    1026 dnl  __(mov arg_x,arg_y)
    1027 dnl 1:
    1028 dnl  __(cmp arg_x,#nil_value)
    1029 dnl  __(la imm0,node_size(imm0))
    1030 dnl  __(_cdr(arg_x,arg_x))
    1031 dnl  __(bne 1b)
    1032 dnl  /* imm0 is now (boxed) triplet count.  */
    1033 dnl  /* Determine word count, add 1 (to align), and make room.  */
    1034 dnl  /* if count is 0, make an empty tsp frame and exit  */
    1035 dnl  __(cmp imm0,#0)
    1036 dnl  __(add imm1,imm0,imm0)
    1037 dnl  __(add imm1,imm1,imm0)
    1038 dnl         __(dnode_align(imm1,imm1,node_size))
    1039 dnl  __(bne+ 2f)
    1040 dnl   __(TSP_Alloc_Fixed_Boxed(2*node_size))
    1041 dnl   __(bx lr)
    1042 dnl 2:
    1043 dnl  __(la imm1,tsp_frame.fixed_overhead(imm1)) /* tsp header  */
    1044 dnl  __(TSP_Alloc_Var_Boxed_nz(imm1,imm2))
    1045 dnl  __(str(imm0,tsp_frame.data_offset(tsp)))
    1046 dnl  __(ldr imm2,[tsp,#tsp_frame.backlink])
    1047 dnl  __(mov arg_x,arg_y)
    1048 dnl  __(ldr imm1,[rcontext,#tcr.db_link])
    1049 dnl         __(ldr imm3,[rcontext,#tcr.tlb_limit])
    1050 dnl 3:
    1051 dnl         __(cmpri(cr1,arg_z,nil_value))
    1052 dnl  __(_car(temp0,arg_x))
    1053 dnl         __(ldr imm0,[temp0,#symbol.binding_index])
    1054 dnl  __(_cdr(arg_x,arg_x))
    1055 dnl         __(trlle(imm3,imm0))
    1056 dnl         __(ldr imm4,[rcontext,#tcr.tlb_pointer]) /* Need to reload after trap  */
    1057 dnl         __(ldrx(temp3,imm4,imm0))
    1058 dnl  __(cmp arg_x,#nil_value)
    1059 dnl         __(mov temp2,#unbound_marker)
    1060 dnl         __(beq cr1,4f)
    1061 dnl  __(_car(temp2,arg_z))
    1062 dnl  __(_cdr(arg_z,arg_z))
    1063 dnl 4:      __(push(temp3,imm2))
    1064 dnl  __(push(imm0,imm2))
    1065 dnl  __(push(imm1,imm2))
    1066 dnl         __(str temp2,imm4,imm0)
    1067 dnl  __(mov imm1,imm2)
    1068 dnl  __(bne 3b)
    1069 dnl  __(str(imm2,tcr.db_link(rcontext)))
    1070 dnl  __(bx lr)
    1071 dnl
    1072 dnl 
     1000        __(b (C(progvsave)))
     1001 
    10731002       
    10741003/* Allocate a uvector on the  stack.  (Push a frame on the stack and  */
     
    23542283_spentry(progvrestore)
    23552284        __(skip_stack_vector(imm0,imm1,sp))
    2356         /* There might be a lisp_frame at imm0.  Not sure */
    2357         __(ldr imm0,[imm0,#node_size]) /* or maybe node_size+lisp_frame.size */
     2285        __(ldr imm0,[imm0,#lisp_frame.size+node_size])
    23582286        __(cmp imm0,#0)
    23592287        __(unbox_fixnum(imm0,imm0))
     
    40573985        __(bx lr)
    40583986_endfn               
    4059                        
     3987
     3988_exportfn(C(progvsave))       
     3989        /* Error if arg_z isn't a proper list.  That's unlikely, */
     3990        /* but it's better to check now than to crash later. */
     3991        __(cmp arg_z,#nil_value)
     3992        __(mov arg_x,arg_z) /* fast  */
     3993        __(mov temp1,arg_z) /* slow  */
     3994        __(beq 9f)  /* Null list is proper  */
     39950:
     3996        __(trap_unless_list(arg_x,imm0))
     3997        __(_cdr(temp2,arg_x)) /* (null (cdr fast)) ?  */
     3998        __(trap_unless_list(temp2,imm0,cr0))
     3999        __(cmp temp2,#nil_value)
     4000        __(_cdr(arg_x,temp2))
     4001        __(beq 9f)
     4002        __(_cdr(temp1,temp1))
     4003        __(cmp arg_x,temp1)
     4004        __(bne 0b)
     4005        __(mov arg_y,#XIMPROPERLIST)
     4006        __(set_nargs(2))
     4007        __(b _SPksignalerr)
     40089:      /* Whew   */
     4009 
     4010        /* Next, determine the length of arg_y.  We  */
     4011        /* know that it's a proper list.  */
     4012        __(mov imm0,#0)
     4013        __(mov arg_x,arg_y)
     40141:
     4015        __(cmp arg_x,#nil_value)
     4016        __(addne imm0,imm0,#node_size)
     4017        __(_cdr(arg_x,arg_x))
     4018        __(bne 1b)
     4019        /* imm0 is now (boxed) triplet count.  */
     4020        /* Determine word count, add 1 (to align), and make room.  */
     4021        /* if count is 0, make an empty tsp frame and exit  */
     4022        __(cmp imm0,#0)
     4023        __(add imm1,imm0,imm0,lsl #1)
     4024        __(add imm1,imm1,#node_size) /* Room for binding count */
     4025        __(dnode_align(imm2,imm1,node_size))
     4026        __(bne 2f)
     4027        __(movc16(imm0,make_header(1,subtag_simple_vector)))
     4028        __(mov imm1,#0)
     4029        __(stmdb sp!,{imm0,imm1})
     4030        __(b 9f)
     40312:
     4032        __(mov imm1,imm1,lsl #num_subtag_bits-fixnumshift)
     4033        __(orr imm1,imm1,#subtag_u32_vector)
     4034        __(mov temp1,sp)
     4035        __(stack_allocate_zeroed_ivector(imm1,imm2))
     4036        __(mov imm1,#subtag_simple_vector)
     4037        __(strb imm1,[sp])
     4038        __(ldr imm1,[rcontext,#tcr.db_link])
     40393:      __(_car(temp0,arg_y))
     4040        __(ldr imm0,[temp0,#symbol.binding_index])
     4041        __(ldr imm2,[rcontext,#tcr.tlb_limit])
     4042        __(_cdr(arg_y,arg_y))
     4043        __(cmp imm2,imm0)
     4044        __(uuo_tlb_too_small(ls,imm0))
     4045        __(ldr arg_x,[rcontext,#tcr.tlb_pointer])
     4046        __(ldr temp0,[arg_x,imm0])
     4047        __(cmp arg_z,#nil_value)
     4048        __(mov temp2,#unbound_marker)
     4049        __(ldrne temp2,[arg_z,#cons.car])
     4050        __(_cdr(arg_z,arg_z))
     4051        __(cmp arg_y,#nil_value)
     4052        __(push1(temp0,temp1))
     4053        __(push1(imm0,temp1))
     4054        __(push1(imm1,temp1))
     4055        __(mov imm1,temp1)
     4056        __(str temp2,[arg_x,imm0])
     4057        __(bne 3b)
     4058        __(str imm1,[rcontext,#tcr.db_link])
     40599:             
     4060        __(mov arg_z,#unbound_marker)
     4061        __(mov imm2,#fixnum_one)
     4062        __(mkcatch())       
     4063        __(bx lr)
     4064_endfn                               
    40604065               
    40614066/* Too large to safely fit on tstack.  Heap-cons the vector, but make  */
  • branches/arm/lisp-kernel/gc-common.c

    r13352 r13897  
    14441444    if (GCDebug) {
    14451445      check_all_areas(tcr);
    1446     }
    14471446    check_static_cons_freelist("in pre-gc static-cons check");
     1447    }
    14481448  }
    14491449
     
    17081708  if (GCDebug) {
    17091709    check_all_areas(tcr);
    1710   }
    1711   check_static_cons_freelist("in post-gc static-cons check");
    1712 
     1710    check_static_cons_freelist("in post-gc static-cons check");
     1711  }
    17131712
    17141713 
  • branches/arm/lisp-kernel/linuxarm/Makefile

    r13855 r13897  
    2323ASFLAGS =
    2424M4FLAGS = -DLINUX -DARM
    25 CDEFINES = -DLINUX -DARM -D_REENTRANT -D_GNU_SOURCE -DDISABLE_EGC
     25CDEFINES = -DLINUX -DARM -D_REENTRANT -D_GNU_SOURCE -DDISABLE_EGC -DGC_INTEGRITY_CHECKING
    2626CDEBUG = -g
    2727COPT = #-O2
  • branches/arm/lisp-kernel/lisp-debug.c

    r13802 r13897  
    507507#endif
    508508
     509#ifdef ARM
     510void
     511describe_arm_uuo(ExceptionInformation *xp)
     512{
     513  pc program_counter = xpPC(xp);
     514  opcode instruction = *program_counter;
     515
     516  if (IS_UUO(instruction)) {
     517    unsigned format = UUO_FORMAT(instruction);
     518
     519    switch(format) {
     520    case uuo_format_nullary:
     521    case uuo_format_nullary_error:
     522      switch UUOA_field(instruction) {
     523      case 0:
     524        fprintf(dbgout,"alloc_trap\n");
     525        break;
     526      case 1:
     527        fprintf(dbgout,"wrong number of args (%d) to %s\n",xpGPR(xp,nargs)>>node_shift,
     528                print_lisp_object(xpGPR(xp,nfn)));
     529        break;
     530      case 2:
     531        fprintf(dbgout,"gc trap\n");
     532        break;
     533      case 3:
     534        fprintf(dbgout,"debug trap\n");
     535        break;
     536      case 4:
     537        fprintf(dbgout,"deferred interrupt\n");
     538        break;
     539      case 5:
     540        fprintf(dbgout,"deferred suspend\n");
     541        break;
     542      default:
     543        break;
     544      }
     545      break;
     546
     547    case uuo_format_unary_error:
     548      switch (UUO_UNARY_field(instruction)) {
     549      case 0:
     550      case 1:
     551        fprintf(dbgout,"%s is unbound\n", print_lisp_object(xpGPR(xp,UUOA_field(instruction))));
     552        break;
     553
     554      default:
     555        break;
     556      }
     557    default:
     558      break;
     559    }
     560  }
     561}
     562#endif
     563
    509564debug_command_return
    510565debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
     
    595650}
    596651
    597 #ifdef PPC
     652#ifndef X86
    598653debug_command_return
    599654debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
     
    627682    break;
    628683  default:
     684    break;
     685  }
     686#endif
     687#ifdef ARM
     688  pc program_counter = xpPC(xp);
     689  opcode instruction = 0;
     690 
     691  switch (arg) {
     692  case SIGILL:
     693    instruction = *program_counter;
     694    if (IS_UUO(instruction)) {
     695      describe_arm_uuo(xp);
     696    }
    629697    break;
    630698  }
     
    656724debug_get_natural_value(char *prompt)
    657725{
    658   char s[32], *res;
     726  char s[32], *res, *endptr;
    659727  int n;
    660728  natural val;
     
    665733    s[0]=0;
    666734    res = fgets(s, 24, stdin);
    667     n = sscanf(s, "%lu", &val);
    668   } while (n != 1);
     735    val = strtoul(res,&endptr,0);
     736  } while (*endptr);
    669737  return val;
    670738}
     
    10241092   "GPR to set (0-31) ?",
    10251093   'G'},
    1026 #ifdef PPC
     1094#ifndef X86
    10271095  {debug_advance_pc,
    10281096   "Advance the program counter by one instruction (use with caution!)",
Note: See TracChangeset for help on using the changeset viewer.