Changeset 8130


Ignore:
Timestamp:
Jan 15, 2008, 1:37:02 PM (12 years ago)
Author:
gb
Message:

Merge changes from working-0711 branch

Location:
branches/1.2/devel/source
Files:
23 edited

Legend:

Unmodified
Added
Removed
  • branches/1.2/devel/source/compiler/X86/X8664/x8664-arch.lisp

    r7935 r8130  
    613613  xtra)
    614614
     615(define-storage-layout tsp-frame 0
     616  backptr
     617  rbp)
     618
     619(define-storage-layout csp-frame 0
     620  backptr
     621  rbp)
     622
     623
    615624(define-storage-layout xcf 0            ;"exception callback frame"
    616625  backptr
     
    621630  xp
    622631  ra0
     632  foreign-sp                            ; value of tcr.foreign_sp
     633  prev-xframe                           ; tcr.xframe before exception
     634                                        ; (last 2 needed by apply-in-frame)
    623635  )
    624636
     
    13161328(defconstant recover-fn-from-rip-byte2 #x2d)
    13171329
     1330;;; For backtrace: the relative PC of an argument-check trap
     1331;;; must be less than or equal to this value.  (Because of
     1332;;; the way that we do "anchored" UUOs, it should always be =.)
     1333
     1334(defconstant arg-check-trap-pc-limit 7)
    13181335
    13191336(provide "X8664-ARCH")
  • branches/1.2/devel/source/compiler/X86/X8664/x8664-vinsns.lisp

    r7980 r8130  
    309309
    310310(define-x8664-vinsn check-min-nargs (()
    311                                        ((n :u16const)))
     311                                       ((min :u16const)))
    312312  :resume
    313   (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift)))
    314   (jb :bad)
     313  ((:pred = min 1)
     314   (testw (:%w x8664::nargs) (:%w x8664::nargs))
     315   (je :toofew))
     316  ((:not (:pred = min 1))
     317   (rcmpw (:%w x8664::nargs) (:$w (:apply ash min x8664::word-shift)))
     318   (jb :toofew)) 
    315319 
    316320  (:anchored-uuo-section :resume)
    317   :bad
     321  :toofew
    318322  (:anchored-uuo (uuo-error-too-few-args)))
    319323
     
    322326  :resume
    323327  (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift)))
    324   (jg :bad)
     328  (ja :bad)
    325329 
    326330  (:anchored-uuo-section :resume)
    327331  :bad
     332  (:anchored-uuo (uuo-error-too-many-args)))
     333
     334
     335(define-x8664-vinsn check-min-max-nargs (()
     336                                         ((min :u16const)
     337                                          (max :u16)))
     338  :resume
     339  ((:pred = min 1)
     340   (testw (:%w x8664::nargs) (:%w x8664::nargs))
     341   (je :toofew))
     342  ((:not (:pred = min 1))
     343   (rcmpw (:%w x8664::nargs) (:$w (:apply ash min x8664::word-shift)))
     344   (jb :toofew))
     345  (rcmpw (:%w x8664::nargs) (:$w (:apply ash max x8664::word-shift)))
     346  (ja :toomany)
     347 
     348  (:anchored-uuo-section :resume)
     349  :toofew
     350  (:anchored-uuo (uuo-error-too-few-args))
     351  (:anchored-uuo-section :resume)
     352  :toomany
    328353  (:anchored-uuo (uuo-error-too-many-args)))
    329354
     
    17311756  (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%mmx x8664::stack-temp))
    17321757  (movq (:%mmx x8664::stack-temp) (:@ (:%q temp)))
     1758  (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp)))
    17331759  (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp))
    17341760  (leaq (:@ (+ x8664::dnode-size x8664::fulltag-cons) (:%q temp)) (:%q temp))
     
    17591785  (jnz :loop)
    17601786  (movq (:%mmx x8664::stack-temp) (:@ (:%q tempa)))
     1787  (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q tempa)))
    17611788  (movq (:%q tempa) (:@ (:%seg :rcontext) x8664::tcr.save-tsp))
    17621789  (movl (:$l header) (:@ x8664::dnode-size (:%q tempa)))
     
    21012128     ((w :u64)))
    21022129  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) 
    2103   (subq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
    2104   (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) 
     2130  (subq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
     2131  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0))
    21052132  (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))
    2106   (movq (:%q w) (:@ 8 (:%q x8664::ra0))))
     2133  (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))
     2134  (movq (:%q w) (:@ x8664::dnode-size (:%q x8664::ra0))))
    21072135
    21082136
     
    21172145  (movapd (:%xmm x8664::fpzero) (:@ 16 (:%q temp)))
    21182146  (movq (:%mmx x8664::stack-temp) (:@ (:%q temp)))
     2147  (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) 
    21192148  (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp))
    21202149  (movq (:%q w) (:@ x8664::dnode-size (:%q temp))))
     
    21242153     ((f :double-float)))
    21252154  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) 
    2126   (subq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
     2155  (subq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
    21272156  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) 
    21282157  (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))
    2129   (movsd (:%xmm f) (:@ 8 (:%q x8664::ra0))))
     2158  (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))
     2159  (movapd (:%xmm f) (:@ x8664::dnode-size (:%q x8664::ra0))))
    21302160
    21312161
     
    21462176     ())
    21472177  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0))
    2148   (movq (:@ 8 (:%q x8664::ra0)) (:%q w))
    2149   (addq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)))
     2178  (movq (:@ x8664::dnode-size (:%q x8664::ra0)) (:%q w))
     2179  (addq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)))
    21502180
    21512181
     
    21642194     ())
    21652195  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0))
    2166   (movsd (:@ 8 (:%q x8664::ra0)) (:%xmm f))
    2167   (addq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)))
     2196  (movapd (:@ x8664::dnode-size (:%q x8664::ra0)) (:%xmm f))
     2197  (addq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)))
    21682198
    21692199
     
    21722202                                   ((ptr :address)))
    21732203  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp))
    2174   (subq (:$b (+ 16 x8664::macptr.size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
     2204  (subq (:$b (+ x8664::dnode-size x8664::macptr.size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
    21752205  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0))
    21762206  (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))
    2177   (leaq (:@ (+ 16 x8664::fulltag-misc) (:%q  x8664::ra0)) (:%q dest))
     2207  (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))
     2208  (leaq (:@ (+ x8664::dnode-size x8664::fulltag-misc) (:%q  x8664::ra0)) (:%q dest))
    21782209  (movq (:$l x8664::macptr-header) (:@ x8664::macptr.header (:%q dest)))
    21792210  (movq (:%q ptr) (:@ x8664::macptr.address (:%q dest)))
     
    35843615   (subq (:$l (:apply ash (:apply logandc2 (:apply + nwords 9) 1) x8664::word-shift)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)))
    35853616  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0))
    3586   (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))))
     3617  (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))
     3618  (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))))
    35873619
    35883620(define-x8664-vinsn alloc-variable-c-frame (()
     
    35953627  (subq (:%q size) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))
    35963628  (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0))
    3597   (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))))
     3629  (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))
     3630  (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))))
    35983631
    35993632(define-x8664-vinsn set-c-arg (()
     
    36563689  (movapd (:%xmm x8664::fpzero) (:@ (:%q temp)))
    36573690  (movapd (:%xmm x8664::fpzero) (:@ x8664::dnode-size (:%q temp)))
    3658   (movq (:%mmx x8664::stack-temp) (:@ (:%q temp)))
     3691  (movq (:%mmx x8664::stack-temp) (:@ (:%q temp)))
     3692  (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) 
    36593693  (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) 
    36603694  (movq (:$l x8664::value-cell-header) (:@ x8664::dnode-size (:%q temp)))
  • branches/1.2/devel/source/compiler/X86/x86-disassemble.lisp

    r7937 r8130  
    22322232  (let* ((stop t))
    22332233    (cond ((and (>= intop #x70) (< intop #x80))
    2234            (setq stop nil)
    22352234           (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds)))
    22362235             (setf (x86-di-mnemonic instruction)
  • branches/1.2/devel/source/compiler/X86/x86-lap.lisp

    r7858 r8130  
    10151015        (finish-pending-talign-frag frag-list)))))
    10161016
    1017 (defun x86-lap-directive (frag-list directive arg)
    1018   (if (eq directive :tra)
    1019     (progn
    1020       (finish-frag-for-align frag-list 3)
    1021       (x86-lap-directive frag-list :long `(:^ ,arg))
    1022       (emit-x86-lap-label frag-list arg))
    1023     (if (eq directive :fixed-constants)
    1024       (dolist (constant arg)
    1025         (ensure-x86-lap-constant-label constant))
    1026       (if (eq directive :arglist)
    1027         (setq *x86-lap-lfun-bits* (encode-lambda-list arg))
    1028         (let* ((exp (parse-x86-lap-expression arg))
    1029                (constantp (or (constant-x86-lap-expression-p exp)
    1030                               (not (x86-lap-expression-p exp)))))
    1031                
    1032           (if constantp
    1033             (let* ((val (x86-lap-expression-value exp)))
    1034               (ecase directive
    1035                 (:code-size
    1036                  (if *x86-lap-fixed-code-words*
    1037                    (error "Duplicate :CODE-SIZE directive")
    1038                    (setq *x86-lap-fixed-code-words* val)))
    1039                 (:byte (frag-list-push-byte frag-list val))
    1040                 (:short (frag-list-push-16 frag-list val))
    1041                 (:long (frag-list-push-32 frag-list val))
    1042                 (:quad (frag-list-push-64 frag-list val))
    1043                 (:align (finish-frag-for-align frag-list val))
    1044                 (:talign (finish-frag-for-talign frag-list val))
    1045                 (:org (finish-frag-for-org frag-list val))))
    1046             (let* ((pos (frag-list-position frag-list))
    1047                    (frag (frag-list-current frag-list))
    1048                    (reloctype nil))
    1049               (ecase directive
    1050                 (:byte (frag-list-push-byte frag-list 0)
    1051                        (setq reloctype :expr8))
    1052                 (:short (frag-list-push-16 frag-list 0)
    1053                         (setq reloctype :expr16))
    1054                 (:long (frag-list-push-32 frag-list 0)
    1055                        (setq reloctype :expr32))
    1056                 (:quad (frag-list-push-64 frag-list 0)
    1057                        (setq reloctype :expr64))
    1058                 (:align (error ":align expression ~s not constant" arg))
    1059                 (:talign (error ":talign expression ~s not constant" arg)))
    1060               (when reloctype
    1061                 (push
    1062                  (make-reloc :type reloctype
    1063                              :arg exp
    1064                              :pos pos
    1065                              :frag frag)
    1066                  (frag-relocs frag)))))
    1067           nil)))))
     1017;;; Returns the active frag list after processing directive(s).
     1018(defun x86-lap-directive (frag-list directive arg &optional main-frag-list exception-frag-list)
     1019  (declare (ignorable main-frag-list exception-frag-list))
     1020  (case directive
     1021    (:tra
     1022     (finish-frag-for-align frag-list 3)
     1023     (x86-lap-directive frag-list :long `(:^ ,arg))
     1024     (emit-x86-lap-label frag-list arg))
     1025    (:fixed-constants
     1026     (dolist (constant arg)
     1027       (ensure-x86-lap-constant-label constant)))
     1028    (:arglist (setq *x86-lap-lfun-bits* (encode-lambda-list arg)))
     1029    ((:uuo :uuo-section)
     1030     (if exception-frag-list
     1031       (progn
     1032         (setq frag-list exception-frag-list)
     1033         (finish-frag-for-align frag-list 2))))
     1034    ((:main :main-section)
     1035     (when main-frag-list (setq frag-list main-frag-list)))
     1036    (:anchored-uuo-section
     1037     (setq frag-list (x86-lap-directive frag-list :uuo-section nil main-frag-list exception-frag-list))
     1038     (setq frag-list (x86-lap-directive frag-list :long `(:^ ,arg) main-frag-list exception-frag-list)))
     1039    (t (let* ((exp (parse-x86-lap-expression arg))
     1040              (constantp (or (constant-x86-lap-expression-p exp)
     1041                             (not (x86-lap-expression-p exp)))))
     1042         
     1043         (if constantp
     1044           (let* ((val (x86-lap-expression-value exp)))
     1045             (ecase directive
     1046               (:code-size
     1047                (if *x86-lap-fixed-code-words*
     1048                  (error "Duplicate :CODE-SIZE directive")
     1049                  (setq *x86-lap-fixed-code-words* val)))
     1050               (:byte (frag-list-push-byte frag-list val))
     1051               (:short (frag-list-push-16 frag-list val))
     1052               (:long (frag-list-push-32 frag-list val))
     1053               (:quad (frag-list-push-64 frag-list val))
     1054               (:align (finish-frag-for-align frag-list val))
     1055               (:talign (finish-frag-for-talign frag-list val))
     1056               (:org (finish-frag-for-org frag-list val))))
     1057           (let* ((pos (frag-list-position frag-list))
     1058                  (frag (frag-list-current frag-list))
     1059                  (reloctype nil))
     1060             (ecase directive
     1061               (:byte (frag-list-push-byte frag-list 0)
     1062                      (setq reloctype :expr8))
     1063               (:short (frag-list-push-16 frag-list 0)
     1064                       (setq reloctype :expr16))
     1065               (:long (frag-list-push-32 frag-list 0)
     1066                      (setq reloctype :expr32))
     1067               (:quad (frag-list-push-64 frag-list 0)
     1068                      (setq reloctype :expr64))
     1069               (:align (error ":align expression ~s not constant" arg))
     1070               (:talign (error ":talign expression ~s not constant" arg)))
     1071             (when reloctype
     1072               (push
     1073                (make-reloc :type reloctype
     1074                            :arg exp
     1075                            :pos pos
     1076                            :frag frag)
     1077                (frag-relocs frag))))))))
     1078  frag-list)
    10681079
    10691080
     
    10811092         
    10821093
    1083 (defun x86-lap-form (form frag-list instruction)
     1094(defun x86-lap-form (form frag-list instruction  main-frag-list exception-frag-list)
    10841095  (if (and form (symbolp form))
    10851096    (emit-x86-lap-label frag-list form)
     
    10891100          (x86-lap-macroexpand-1 form)
    10901101        (if expanded
    1091           (x86-lap-form expansion frag-list instruction)
     1102          (x86-lap-form expansion frag-list instruction main-frag-list exception-frag-list)
    10921103          (if (typep (car form) 'keyword)
    1093             (destructuring-bind (op arg) form
    1094               (x86-lap-directive frag-list op arg))
     1104            (destructuring-bind (op &optional arg) form
     1105              (setq frag-list (x86-lap-directive frag-list op arg main-frag-list exception-frag-list)))
    10951106            (case (car form)
    10961107              (progn
    10971108                (dolist (f (cdr form))
    1098                   (x86-lap-form f frag-list instruction)))
     1109                  (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))))
    10991110              (let
    11001111                  (destructuring-bind (equates &body body)
    11011112                      (cdr form)
    1102                     (x86-lap-equate-form equates frag-list instruction body)))
     1113                    (setq frag-list (x86-lap-equate-form equates frag-list instruction body main-frag-list exception-frag-list))))
    11031114              (t
    11041115               (parse-x86-instruction form instruction)
    1105                (x86-generate-instruction-code frag-list instruction)))))))))
     1116               (x86-generate-instruction-code frag-list instruction))))))))
     1117  frag-list)
    11061118
    11071119(defun relax-align (address bits)
     
    13021314      (format t "~2,'0x " (frag-ref frag i)))))
    13031315
    1304 (defun x86-lap-equate-form (eqlist fraglist instruction  body)
     1316(defun x86-lap-equate-form (eqlist fraglist instruction  body main-frag exception-frag)
    13051317  (let* ((symbols (mapcar #'(lambda (x)
    13061318                              (let* ((name (car x)))
     
    13201332                         eqlist)))
    13211333    (progv symbols values
    1322       (dolist (form body)
    1323         (x86-lap-form form fraglist instruction)))))         
     1334      (dolist (form body fraglist)
     1335        (setq fraglist (x86-lap-form form fraglist instruction main-frag exception-frag))))))
    13241336               
    13251337(defun cross-create-x86-function (name frag-list constants bits debug-info)
     
    13851397         (entry-code-tag (gensym))
    13861398         (instruction (x86::make-x86-instruction))
    1387          (frag-list (make-frag-list)))
     1399         (main-frag-list (make-frag-list))
     1400         (exception-frag-list (make-frag-list))
     1401         (frag-list main-frag-list))
    13881402    (make-x86-lap-label end-code-tag)
    13891403    (make-x86-lap-label entry-code-tag)
     
    13941408    (x86-lap-directive frag-list :byte 0) ;regsave mask
    13951409    (emit-x86-lap-label frag-list entry-code-tag)
    1396     (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction)
     1410
     1411    (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list)
    13971412    (dolist (f forms)
    1398       (x86-lap-form f frag-list instruction))
     1413      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
     1414    (setq frag-list main-frag-list)
     1415    (merge-dll-nodes frag-list exception-frag-list)
    13991416    (x86-lap-directive frag-list :align 3)
    14001417    (when *x86-lap-fixed-code-words*
  • branches/1.2/devel/source/compiler/X86/x86-lapmacros.lisp

    r6469 r8130  
    3131    `(movw ($ ',n) (% nargs))))
    3232
     33(defx86lapmacro anchored-uuo (form)
     34  `(progn
     35    ,form
     36    (:byte 0)))
     37
    3338(defx86lapmacro check-nargs (min &optional (max min))
    34   (let* ((ok (gensym)))
     39  (let* ((anchor (gensym))
     40         (bad (gensym)))
    3541    (if (and max (= max min))
    3642      `(progn
    37         (rcmp (% nargs) ($ ',min))
    38         (je.pt ,ok)
    39         (uuo-error-wrong-number-of-args)
    40         ,ok)
     43        ,anchor
     44        ,(if (eql min 0)
     45             `(testw (% nargs) (% nargs))
     46             `(rcmp (% nargs) ($ ',min)))
     47        (jne ,bad)
     48        (:anchored-uuo-section ,anchor)
     49        ,bad
     50        (anchored-uuo (uuo-error-wrong-number-of-args))
     51        (:main-section nil))
    4152      (if (null max)
    4253        (unless (zerop min)
    4354          `(progn
     55            ,anchor
    4456            (rcmp (% nargs) ($ ',min))
    45             (jae.pt  ,ok)
    46             (uuo-error-too-few-args)
    47             ,ok))
     57            (jb ,bad)
     58            (:anchored-uuo-section ,anchor)
     59            ,bad
     60            (anchored-uuo (uuo-error-too-few-args))
     61            (:main-section nil)))
    4862        (if (zerop min)
    4963          `(progn
     64            ,anchor
    5065            (rcmp (% nargs) ($ ',max))
    51             (jb.pt  ,ok)
    52             (uuo-error-too-many-args)
    53             ,ok)
    54           (let* ((sofar (gensym)))
     66            (ja ,bad)
     67            (:anchored-uuo-section ,anchor)
     68            ,bad
     69            (anchored-uuo (uuo-error-too-many-args))
     70            (:main-section nil))
     71          (let* ((toofew (gensym))
     72                 (toomany (gensym)))
    5573            `(progn
     74              ,anchor
    5675              (rcmp (% nargs) ($ ',min))
    57               (jae.pt  ,sofar)
    58               (uuo-error-too-few-args)
    59               ,sofar
     76              (jb ,toofew)
    6077              (rcmp (% nargs) ($ ',max))
    61               (jbe.pt  ,ok)
    62               (uuo-error-too-many-args)
    63               ,ok)))))))
     78              (ja ,toomany)
     79              (:anchored-uuo-section ,anchor)
     80              ,toofew
     81              (anchored-uuo (uuo-error-too-few-args))
     82              (:anchored-uuo-section ,anchor)
     83              ,toomany
     84              (anchored-uuo (uuo-error-too-many-args)))))))))
    6485
    6586
  • branches/1.2/devel/source/compiler/optimizers.lisp

    r7961 r8130  
    919919;;; (<typecheck> foo)).
    920920(define-compiler-macro require-type (&whole call &environment env arg type)
    921   (cond ((and (quoted-form-p type)
    922               (setq type (%cadr type))
     921  (cond ((and (or (eq type t)
     922                  (and (quoted-form-p type)
     923                       (setq type (%cadr type))))
    923924              (not (typep (specifier-type type) 'unknown-ctype)))       
    924925         (cond ((nx-form-typep arg type env) arg)
     
    964965               ((type= (specifier-type type)
    965966                       (specifier-type '(unsigned-byte 64)))
    966                 `(the (unsigned-byte 64) (require-u64 ,arg)))               
     967                `(the (unsigned-byte 64) (require-u64 ,arg)))
     968               #+nil
    967969               ((and (symbolp type)
    968970                     (let ((simpler (type-predicate type)))
    969971                       (if simpler `(the ,type (%require-type ,arg ',simpler))))))
     972               #+nil
    970973               ((and (symbolp type)(find-class type nil env))
    971974                  `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
     
    15301533  (declare (ignore e))
    15311534  (if (quoted-form-p type)
    1532     (or (optimize-typep thing (%cadr type) env)
    1533         call)
     1535    (if (constantp thing)
     1536      (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type))
     1537      (or (optimize-typep thing (%cadr type) env)
     1538          call))
    15341539    (if (eq type t)
    15351540      `(progn ,thing t)
     
    20132018    call))
    20142019
     2020(define-compiler-macro instance-slots (&whole w instance)
     2021  (if (and (constantp instance)
     2022           (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance)))
     2023    `(instance.slots ,instance)
     2024    w))
     2025
     2026(define-compiler-macro unsigned-byte-p (x)
     2027  (if (typep (nx-unquote x) 'unsigned-byte)
     2028    t
     2029    (let* ((val (gensym)))
     2030      `(let* ((,val ,x))
     2031        (and (integerp ,val) (not (< ,val 0)))))))
     2032
    20152033(provide "OPTIMIZERS")
    20162034
  • branches/1.2/devel/source/level-0/X86/x86-misc.lisp

    r7886 r8130  
    513513  (single-value-return))
    514514
    515 #+are-you-kidding
    516 (defx86lapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
    517                                      (parent arg_x) (function arg_y) (arglist arg_z))
    518   (check-nargs 7)
    519 
    520   ; Throw through catch-count catch frames
    521   (lwz imm0 12 vsp)                      ; catch-count
    522   (vpush parent)
    523   (vpush function)
    524   (vpush arglist)
    525   (bla .SPnthrowvalues)
    526 
    527   ; Pop tsp-count TSP frames
    528   (lwz tsp-count 16 vsp)
    529   (cmpi cr0 tsp-count 0)
    530   (b @test)
    531 @loop
    532   (subi tsp-count tsp-count '1)
    533   (cmpi cr0 tsp-count 0)
    534   (lwz tsp 0 tsp)
    535 @test
    536   (bne cr0 @loop)
    537 
    538   ; Pop dynamic bindings until we get to db-link
    539   (lwz imm0 12 vsp)                     ; db-link
    540   (lwz imm1 x8664::tcr.db-link :rcontext)
    541   (cmp cr0 imm0 imm1)
    542   (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
    543   (bla .SPunbind-to)
    544 
    545 @restore-regs
    546   ; restore the saved registers from srv
    547   (lwz srv 20 vsp)
    548 @get0
    549   (svref imm0 1 srv)
    550   (cmpwi cr0 imm0 x8664::nil-value)
    551   (beq @get1)
    552   (lwz save0 0 imm0)
    553 @get1
    554   (svref imm0 2 srv)
    555   (cmpwi cr0 imm0 x8664::nil-value)
    556   (beq @get2)
    557   (lwz save1 0 imm0)
    558 @get2
    559   (svref imm0 3 srv)
    560   (cmpwi cr0 imm0 x8664::nil-value)
    561   (beq @get3)
    562   (lwz save2 0 imm0)
    563 @get3
    564   (svref imm0 4 srv)
    565   (cmpwi cr0 imm0 x8664::nil-value)
    566   (beq @get4)
    567   (lwz save3 0 imm0)
    568 @get4
    569   (svref imm0 5 srv)
    570   (cmpwi cr0 imm0 x8664::nil-value)
    571   (beq @get5)
    572   (lwz save4 0 imm0)
    573 @get5
    574   (svref imm0 6 srv)
    575   (cmpwi cr0 imm0 x8664::nil-value)
    576   (beq @get6)
    577   (lwz save5 0 imm0)
    578 @get6
    579   (svref imm0 7 srv)
    580   (cmpwi cr0 imm0 x8664::nil-value)
    581   (beq @get7)
    582   (lwz save6 0 imm0)
    583 @get7
    584   (svref imm0 8 srv)
    585   (cmpwi cr0 imm0 x8664::nil-value)
    586   (beq @got)
    587   (lwz save7 0 imm0)
    588 @got
    589 
    590   (vpop arg_z)                          ; arglist
    591   (vpop temp0)                          ; function
    592   (vpop parent)                         ; parent
    593   (extract-lisptag imm0 parent)
    594   (cmpi cr0 imm0 x8664::tag-fixnum)
    595   (if (:cr0 :ne)
    596     ; Parent is a fake-stack-frame. Make it real
    597     (progn
    598       (svref sp %fake-stack-frame.sp parent)
    599       (stwu sp (- x8664::lisp-frame.size) sp)
    600       (svref fn %fake-stack-frame.fn parent)
    601       (stw fn x8664::lisp-frame.savefn sp)
    602       (svref temp1 %fake-stack-frame.vsp parent)
    603       (stw temp1 x8664::lisp-frame.savevsp sp)
    604       (svref temp1 %fake-stack-frame.lr parent)
    605       (extract-lisptag imm0 temp1)
    606       (cmpi cr0 imm0 x8664::tag-fixnum)
    607       (if (:cr0 :ne)
    608         ;; must be a macptr encoding the actual link register
    609         (macptr-ptr loc-pc temp1)
    610         ;; Fixnum is offset from start of function vector
    611         (progn
    612           (svref temp2 0 fn)        ; function vector
    613           (unbox-fixnum temp1 temp1)
    614           (add loc-pc temp2 temp1)))
    615       (stw loc-pc x8664::lisp-frame.savelr sp))
    616     ;; Parent is a real stack frame
    617     (mr sp parent))
    618   (set-nargs 0)
    619   (bla .SPspreadargz)
    620   (ba .SPtfuncallgen))
    621515
    622516
     
    760654  (restore-simple-frame)
    761655  (single-value-return))
     656
     657;;; This is a prototype; it can't easily keep its arguments on the stack,
     658;;; or in registers, because its job involves unwinding the stack and
     659;;; restoring registers.  Its parameters are thus kept in constants,
     660;;; and this protoype is cloned (with the right parameters).
     661
     662(defx86lapfunction %%apply-in-frame-proto ()
     663  (:fixed-constants (target-frame target-catch target-db-link target-xcf target-tsp target-foreign-sp save0-offset save1-offset save2-offset save3-offset function args))
     664  (check-nargs 0)
     665  ;;(uuo-error-debug-trap)
     666  (movq (@ 'target-catch (% fn)) (% temp0))
     667  (xorl (%l imm0) (%l imm0))
     668  (cmpb ($ x8664::fulltag-nil) (%b temp0))
     669  (movq (@ (% :rcontext) target::tcr.catch-top) (% arg_z))
     670  (jz @did-catch)
     671  @find-catch
     672  (testq (% arg_z) (% arg_z))
     673  (jz @did-catch)                       ; never found target catch
     674  (addq ($ '1)  (% imm0))
     675  (cmpq (% temp0) (% arg_z))
     676  (je @found-catch)
     677  (movq (@ target::catch-frame.link (% arg_z)) (% arg_z))
     678  (jmp @find-catch)
     679  @found-catch
     680  (set-nargs 0)                         ; redundant, but ...
     681  (lea (@ (:^ @back-from-nthrow) (% fn)) (% ra0))
     682  (:talign 4)
     683  (jmp-subprim .SPnthrowvalues)
     684  @back-from-nthrow
     685  (recover-fn-from-rip)
     686  @did-catch
     687  ;; Restore special bindings
     688  (movq (@ 'target-db-link (% fn)) (% imm0))
     689  (cmpb ($ x8664::fulltag-nil) (%b imm0))
     690  (jz @no-unbind)
     691  (call-subprim .SPunbind-to)
     692  @no-unbind
     693  ;; If there's at least one exception frame between the target
     694  ;; frame and the last catch (or the point of departure), restore
     695  ;; the NVRs and foreign sp from the oldest such frame
     696  (movq (@ 'target-xcf (% fn)) (% arg_z))
     697  (cmpb ($ x8664::fulltag-nil) (%b arg_z))
     698  (jz @no-xcf)
     699  (movq (@ target::xcf.xp (% arg_z)) (% arg_y))
     700  ;; arg_y points to a "portable" ucontext.  Find the platform-specifc
     701  ;; "gpr vector" in the uc_mcontext, load the NVRs and stack/frame
     702  ;; pointer from there.
     703  #+linuxx8664-target
     704  (progn
     705    (addq ($ gp-regs-offset) (% arg_y))
     706    (movq (@ (* #$REG_R15 8) (% arg_y)) (% r15))
     707    (movq (@ (* #$REG_R14 8) (% arg_y)) (% r14))
     708    (movq (@ (* #$REG_R12 8) (% arg_y)) (% r12))
     709    (movq (@ (* #$REG_R11 8) (% arg_y)) (% r11))
     710    (movq (@ (* #$REG_RBP 8) (% arg_y)) (% rbp))
     711    (movq (@ (* #$REG_RSP 8) (% arg_y)) (% rsp)))
     712  #+freebsdx8664-target
     713  (progn
     714    ;; If you think that this is ugly, just wait until you see the Darwin
     715    ;; version.
     716    (addq ($ gp-regs-offset) (% arg_y))
     717    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r15)) -3) (% arg_y)) (% r15))
     718    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r14)) -3) (% arg_y)) (% r14))
     719    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r12)) -3) (% arg_y)) (% r12))
     720    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r11)) -3) (% arg_y)) (% r11))
     721    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rbp)) -3) (% arg_y)) (% rbp))
     722    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rsp) -3) (% arg_y)) (% rsp))))
     723  #+darwinx8664-target
     724  (progn
     725    (fix this))
     726  ;; This is our best (possibly only) chance to get
     727  ;; the foreign sp right.
     728  (movq (@ target::xcf.prev-xframe (% arg_z)) (% temp0))
     729  (movq (@ target::xcf.foreign-sp (% arg_z)) (% imm0))
     730  (movq (% temp0) (@ (% :rcontext) target::tcr.xframe))
     731  (movq (% imm0) (@ (% :rcontext) target::tcr.foreign-sp))
     732  ;; All done processing the xcf.  NVRs may have been
     733  ;; saved between the last catch/last xcf and the
     734  ;; target frame.  The save-n-offset parameter/constants
     735  ;; are either 0 or negative offsets from the target frame
     736  ;; of the stack location where the corresponding GPR
     737  ;; was saved.
     738  @no-xcf
     739  (movq (@ 'target-tsp (% fn)) (% imm0))
     740  (cmpb ($ x8664::fulltag-nil) (%b imm0))
     741  (movq (@ 'target-foreign-sp (% fn)) (% temp0))
     742  (je @no-tsp)
     743  (movq (% imm0) (@ (% :rcontext) target::tcr.save-tsp))
     744  (movq (% imm0) (@ (% :rcontext) target::tcr.next-tsp))
     745  @no-tsp
     746  (cmpb ($ x8664::fulltag-nil) (%b temp0))
     747  (je @no-sp)
     748  (movq (% temp0) (@ (% :rcontext) target::tcr.foreign-sp))
     749  @no-sp
     750  (movq (@ 'target-frame (% fn)) (% rbp))
     751  (movq (@ 'save0-offset (% fn)) (% arg_x))
     752  (movq (@ 'save1-offset (% fn)) (% arg_y))
     753  (movq (@ 'save2-offset (% fn)) (% arg_z))
     754  (movq (@ 'save3-offset (% fn)) (% temp0))
     755  (testq (% arg_x) (% arg_x))
     756  (cmovneq (@ (% rbp) (% arg_x)) (% save0))
     757  (testq (% arg_y) (% arg_y))
     758  (cmovneq (@ (% rbp) (% arg_x)) (% save1))
     759  (testq (% arg_z) (% arg_z))
     760  (cmovneq (@ (% rbp) (% arg_x)) (% save2))
     761  (testq (% temp0) (% temp0))
     762  (cmovneq (@ (% rbp) (% arg_x)) (% save3))
     763  (leave)
     764  (pop (% temp0))                       ; return address, not used by subprim
     765  (set-nargs 0)
     766  (movq (@ 'args (% fn)) (% arg_z))
     767  (lea (@ (:^ @back-from-spread) (% fn)) (% ra0))
     768  (:talign 4)
     769  (jmp-subprim .SPspreadargz)
     770  @back-from-spread
     771  (recover-fn-from-rip)                 ; .SPspreadargz preserves %fn, but ...
     772  (push (% temp0))                      ; return address
     773  (jmp (@ 'function (% fn))))
    762774 
    763775
     776 
     777
     778
     779 
     780
    764781;;; end of x86-misc.lisp
  • branches/1.2/devel/source/level-0/X86/x86-numbers.lisp

    r6481 r8130  
    113113;;; the word below the stack pointer
    114114(defx86lapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
     115  (save-simple-frame)
    115116  (unbox-fixnum divisor imm0)
    116   (movq (% imm0) (@ -8 (% rsp)))
     117  (movq (% imm0) (% imm2))
    117118  (unbox-fixnum dividend imm0)
    118119  (cqto)                                ; imm1 := sign_extend(imm0)
    119   (idivq (@ -8 (% rsp)))
     120  (idivq (% imm2))
     121  (pop (% rbp))
    120122  (movq (% rsp) (% temp0))
    121123  (box-fixnum imm1 arg_y)
  • branches/1.2/devel/source/level-1/l1-clos.lisp

    r7983 r8130  
    20392039        (values nil nil)))))
    20402040
    2041 (defparameter *typecheck-slots-in-optimized-make-instance* nil)
    2042 
    2043 
     2041(defparameter *typecheck-slots-in-optimized-make-instance* t)
    20442042
    20452043
     
    20602058                          t))
    20612059                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
    2062       (let* ((slotds (sort (copy-list (class-slots class)) #'(lambda (x y) (if (consp x) x (if (consp y) y (< x y)))) :key #'slot-definition-location))
     2060      (let* ((slotds (sort (copy-list (class-slots class))
     2061                           #'(lambda (x y)
     2062                               (if (consp x) x (if (consp y) y (< x y))))
     2063                           :key #'slot-definition-location))
    20632064             (default-initargs (class-default-initargs class)))
    20642065        (collect ((keys)
    20652066                  (binds)
     2067                  (class-binds)
    20662068                  (ignorable)
    20672069                  (class-slot-inits)
     
    20692071                  (forms))
    20702072          (flet ((generate-type-check (form type &optional spvar)
    2071                    (if (null *typecheck-slots-in-optimized-make-instance*)
     2073                   (if (or (null *typecheck-slots-in-optimized-make-instance*)
     2074                           (eq type t)
     2075                           (and (quoted-form-p type) (eq (cadr type) t)))
    20722076                     form
    20732077                     (if spvar
    20742078                       `(if ,spvar
    20752079                         (require-type ,form ',type)
    2076                          (%slot-unbound-marker))
     2080                         ,form)
    20772081                       `(require-type ,form ',type)))))
    20782082            (dolist (slot slotds)
    2079               (let* ((initarg (car (slot-definition-initargs slot)))
     2083              (let* ((initargs (slot-definition-initargs slot))
    20802084                     (initfunction (slot-definition-initfunction slot))
    20812085                     (initform (slot-definition-initform slot))
    20822086                     (location (slot-definition-location slot))
     2087                     (location-var nil)
     2088                     (one-initarg-p (null (cdr initargs)))
    20832089                     (name (slot-definition-name slot))
    2084                      (spvar nil)
    2085                      (type (slot-definition-type slot))
    2086                      (initial-value-form (if initfunction
    2087                                            (if (self-evaluating-p initform)
    2088                                              initform
    2089                                              `(funcall ,initfunction))
     2090                     (type (slot-definition-type slot)))
     2091                (when (consp location)
     2092                  (setq location-var (gensym "LOCATION"))
     2093                  (class-binds `(,location-var
     2094                                 (load-time-value
     2095                                  (slot-definition-location ',slot)))))
     2096                (when initfunction
     2097                  (setq initform
     2098                        (if (self-evaluating-p initform)
     2099                            initform
     2100                            `(funcall ,initfunction))))
     2101                (cond ((null initargs)
     2102                       (let ((initial-value-form
     2103                              (if initfunction
     2104                                  (generate-type-check initform type)
     2105                                  `(%slot-unbound-marker))))
     2106                         (if (consp location)
     2107                             (when initfunction
     2108                                 (class-slot-inits
     2109                                  `(when (eq (%slot-unbound-marker) (cdr ,location-var))
     2110                                     (setf (cdr ,location-var) ,initial-value-form))))
     2111                             (forms initial-value-form))))
     2112                      (t (collect ((cond-clauses))
     2113                           (let ((last-cond-clause nil))
     2114                             (dolist (initarg initargs)
     2115                               (let* ((spvar nil)
     2116                                      (name (if one-initarg-p
     2117                                                name
     2118                                                (gensym (string name))))
     2119                                      (initial-value-form
     2120                                       (if (and initfunction
     2121                                                one-initarg-p
     2122                                                (atom location))
     2123                                           initform
    20902124                                           (progn
    20912125                                             (when initarg
     
    20932127                                                            (concatenate
    20942128                                                             'string
    2095                                                              (string name)
     2129                                                             (string initarg)
    20962130                                                             "-P"))))
    2097                                              `(%slot-unbound-marker)))))
    2098                 (when spvar (ignorable spvar))
    2099                 (if initarg
    2100                   (progn
    2101                     (keys (list*
    2102                            (list initarg name)
    2103                            (let* ((default (assq initarg default-initargs)))
    2104                              (if default
    2105                                (destructuring-bind (form function)
    2106                                    (cdr default)
    2107                                  (if (self-evaluating-p form)
    2108                                    form
    2109                                    `(funcall ,function)))
    2110                                initial-value-form))
    2111                            (if spvar (list spvar))))
    2112                     (if (consp location)
    2113                       (class-slot-inits `(unless (eq ,name (%slot-unbound-marker)) (when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,(generate-type-check name type)))))
    2114                       (forms `,(generate-type-check name type spvar))))
    2115                   (progn
    2116                     (when initfunction
    2117                       (setq initial-value-form (generate-type-check initial-value-form type)))
    2118                     (if (consp location)
    2119                       (if initfunction
    2120                         (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,initial-value-form))))
    2121                    
    2122                       (forms initial-value-form)))))))
     2131                                             (and one-initarg-p
     2132                                                  (atom location)
     2133                                                  (if initfunction
     2134                                                      initform
     2135                                                      `(%slot-unbound-marker))))))
     2136                                      (default (assq initarg default-initargs)))
     2137                                 (when spvar (ignorable spvar))
     2138                                 (when default
     2139                                   (destructuring-bind (form function)
     2140                                       (cdr default)
     2141                                     (setq default
     2142                                           (if (self-evaluating-p form)
     2143                                               form
     2144                                               `(funcall ,function)))))
     2145                                 (keys (list*
     2146                                        (list initarg name)
     2147                                        (if (and default one-initarg-p (atom location))
     2148                                            default
     2149                                            initial-value-form)
     2150                                        (if spvar (list spvar))))
     2151                                 (if one-initarg-p
     2152                                     (if (consp location)
     2153                                         (class-slot-inits
     2154                                          `(if ,spvar
     2155                                               (setf (cdr ,location-var)
     2156                                                     ,(generate-type-check
     2157                                                       name type))
     2158                                               ,(if default
     2159                                                    `(setf (cdr ,location-var)
     2160                                                           ,(generate-type-check
     2161                                                             default type))
     2162                                                    (when initfunction
     2163                                                      `(when (eq (%slot-unbound-marker)
     2164                                                                 (cdr ,location-var))
     2165                                                         (setf (cdr ,location-var)
     2166                                                               ,(generate-type-check
     2167                                                                 initform type)))))))
     2168                                         (forms `,(generate-type-check name type spvar)))
     2169                                     (progn (cond-clauses `(,spvar ,name))
     2170                                            (when (and default (null last-cond-clause))
     2171                                              (setq last-cond-clause
     2172                                                    `(t ,default)))))))
     2173                             (when (cond-clauses)
     2174                               (when last-cond-clause
     2175                                 (cond-clauses last-cond-clause))
     2176                               (cond ((atom location)
     2177                                      (unless last-cond-clause
     2178                                        (cond-clauses `(t ,initform)))
     2179                                      (forms (generate-type-check
     2180                                              `(cond ,@(cond-clauses))
     2181                                              type)))
     2182                                     (t
     2183                                      (let ((initform-p-var
     2184                                             (unless last-cond-clause
     2185                                               (make-symbol "INITFORM-P")))
     2186                                            (value-var (make-symbol "VALUE")))
     2187                                        (unless last-cond-clause
     2188                                          (cond-clauses
     2189                                           `(t (setq ,initform-p-var t)
     2190                                               ,(if initfunction
     2191                                                    initform
     2192                                                    `(%slot-unbound-marker)))))
     2193                                        (class-slot-inits
     2194                                         `(let* (,@(and initform-p-var
     2195                                                        (list `(,initform-p-var nil)))
     2196                                                 (,value-var
     2197                                                  ,(generate-type-check
     2198                                                    `(cond ,@(cond-clauses)) type)))
     2199                                            (when
     2200                                                ,(if initform-p-var
     2201                                                     `(or (null ,initform-p-var)
     2202                                                          (and (eq (cdr ,location-var)
     2203                                                                   (%slot-unbound-marker))
     2204                                                               (not (eq ,value-var
     2205                                                                        (%slot-unbound-marker)))))
     2206                                                     t)
     2207                                                (setf (cdr ,location-var) ,value-var)))))))))))))))
    21232208          (let* ((cell (make-symbol "CLASS-CELL"))
    21242209                 (args (make-symbol "ARGS"))
     
    21342219              (declare (ignorable ,@(ignorable)))
    21352220              ,@(when after-methods `((declare (dynamic-extent ,args))))
    2136               ,@(class-slot-inits)
     2221              (let (,@(class-binds))
     2222                ,@(class-slot-inits))
    21372223              (let* (,@(binds))
    21382224                (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
  • branches/1.2/devel/source/level-1/l1-error-system.lisp

    r7976 r8130  
    449449(define-condition arithmetic-error (error)
    450450  ((operation :initform nil :initarg :operation :reader arithmetic-error-operation)
    451    (operands :initform nil :initarg :operands :reader arithmetic-error-operands))
    452   (:report (lambda (c s) (format s "~S detected ~&performing ~S on ~:S"
    453                                  (type-of c)
    454                                  (arithmetic-error-operation c)
    455                                  (arithmetic-error-operands c)))))
     451   (operands :initform nil :initarg :operands :reader arithmetic-error-operands)
     452   (status :initform nil :initarg :status :reader arithmetic-error-status))
     453  (:report (lambda (c s)
     454             (format s "~S detected" (type-of c))
     455             (let* ((operands (arithmetic-error-operands c)))
     456               (when operands
     457                 (format s "~&performing ~A on ~:S"
     458                         (arithmetic-error-operation c)
     459                         operands))))))
    456460
    457461(define-condition division-by-zero (arithmetic-error))
  • branches/1.2/devel/source/level-1/l1-processes.lisp

    r7949 r8130  
    242242                           
    243243(defun symbol-value-in-process (sym process)
    244   (symbol-value-in-tcr sym (process-tcr process)))
     244  (if (eq process *current-process*)
     245    (symbol-value sym)
     246    (symbol-value-in-tcr sym (process-tcr process))))
    245247
    246248(defun (setf symbol-value-in-process) (value sym process)
    247   (setf (symbol-value-in-tcr sym (process-tcr process)) value))
     249  (if (eq process *current-process*)
     250    (setf (symbol-value sym) value)
     251    (setf (symbol-value-in-tcr sym (process-tcr process)) value)))
    248252
    249253
  • branches/1.2/devel/source/level-1/l1-readloop-lds.lisp

    r7977 r8130  
    141141                       :count 1
    142142                       :detailed-p t))
     143
     144(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame"
     145  (let* ((frame-sp (nth-raw-frame  i *break-frame* nil)))
     146    (if frame-sp
     147      (apply #'return-from-frame frame-sp values))))
     148
     149(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame"
     150  (let* ((frame-sp (nth-raw-frame  i *break-frame* nil)))
     151    (if frame-sp
     152      (apply-in-frame frame-sp function args))))
     153                         
     154                         
    143155
    144156(define-toplevel-command :break raw (n) "Show raw contents of backtrace frame <n>"
     
    390402(defun abnormal-application-exit ()
    391403  (print-call-history)
     404  (force-output *debug-io*)
    392405  (quit -1))
    393406
     
    575588        (if *continuablep*
    576589          (let* ((*print-circle* *error-print-circle*)
    577                  (*print-level* 10)
    578                  (*print-length* 20)
     590                 (*print-level* *error-print-level*)
     591                 (*print-length* *error-print-length*)
    579592                                        ;(*print-pretty* nil)
    580593                 (*print-array* nil))
  • branches/1.2/devel/source/level-1/x86-trap-support.lisp

    r7856 r8130  
    2929  (defconstant flags-register-offset #$REG_EFL)
    3030  (defconstant rip-register-offset #$REG_RIP)
     31  (defun xp-mxcsr (xp)
     32    (pref xp :ucontext.uc_mcontext.fpregs.mxcsr))
    3133  (defparameter *encoded-gpr-to-indexed-gpr*
    3234    #(13                                ;rax
     
    5456  (defconstant flags-register-offset 22)
    5557  (defconstant rip-register-offset 20)
     58  (defun xp-mxcsr (xp)
     59    (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate)))
     60      (pref state :savefpu.sv_env.en_mxcsr)))
    5661  (defparameter *encoded-gpr-to-indexed-gpr*
    5762    #(7                                 ;rax
     
    97102                 (:uc_mcsize (:unsigned 64))
    98103                 (:uc_mcontext64 (:* (:struct :portable_mcontext64))))))
     104  (defun xp-mxcsr (xp)
     105    (%get-unsigned-long
     106     (pref (pref xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.fs) 32))
    99107  (defconstant gp-regs-offset 0)
    100108  (defmacro xp-gp-regs (xp)
     
    210218               (%error (make-condition condition-name
    211219                                       :operation operation
    212                                        :operands operands)
     220                                       :operands operands
     221                                       :status (xp-mxcsr xp))
    213222                       ()
    214223                       frame-ptr))))
  • branches/1.2/devel/source/lib/arglist.lisp

    r7972 r8130  
    205205              (keys))
    206206      (let* ((rest nil)
    207              (map (car (function-symbol-map lfun))))
     207             (map (if (> pc target::arg-check-trap-pc-limit)
     208                    (car (function-symbol-map lfun)))))
    208209        (if (and map pc)
    209210          (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0)))
  • branches/1.2/devel/source/lib/backtrace.lisp

    r7624 r8130  
    9696          (call 'funcall)
    9797          (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))
    98       (multiple-value-bind (req opt restp keys)
    99           (function-args lfun)
    100         (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
    101           (let* ((arglist (arglist-from-map lfun)))
    102             (if (null arglist)
    103               (call "???")
    104               (progn
    105                 (dotimes (i req)
    106                   (let* ((val (argument-value context cfp lfun pc (pop arglist))))
    107                     (if (eq val (%unbound-marker))
    108                       (call "?")
    109                       (call (let* ((*print-length* *backtrace-print-length*)
    110                                    (*print-level* *backtrace-print-level*))
    111                               (format nil "~s" val))))))
    112                 (if (or restp keys (not (eql opt 0)))
    113                   (call "[...]"))
    114                 ))))))
    115     (call)))
     98      (if (<= pc target::arg-check-trap-pc-limit)
     99        (append (call) (arg-check-call-arguments cfp lfun))
     100        (multiple-value-bind (req opt restp keys)
     101            (function-args lfun)
     102          (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
     103            (let* ((arglist (arglist-from-map lfun)))
     104              (if (null arglist)
     105                (call "???")
     106                (progn
     107                  (dotimes (i req)
     108                    (let* ((val (argument-value context cfp lfun pc (pop arglist))))
     109                      (if (eq val (%unbound-marker))
     110                        (call "?")
     111                        (call (let* ((*print-length* *backtrace-print-length*)
     112                                     (*print-level* *backtrace-print-level*))
     113                                (format nil "~s" val))))))
     114                  (if (or restp keys (not (eql opt 0)))
     115                    (call "[...]"))))))
     116          (call))))))
    116117
    117118
     
    150151            (unless (and (typep detailed-p 'fixnum)
    151152                         (not (= (the fixnum detailed-p) frame-number)))
    152               (format t "~&(~x) : ~D ~a ~d"
     153              (format t "~&~c(~x) : ~D ~a ~d"
     154                      (if (exception-frame-p p)  #\* #\space)
    153155                      (index->address p) frame-number
    154156                      (if lfun (backtrace-call-arguments context p lfun pc))
  • branches/1.2/devel/source/lib/ppc-backtrace.lisp

    r7624 r8130  
    350350    (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell))
    351351          value)))
     352
     353;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
     354;;; pretty PPC-specific
     355
     356;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
     357(defun set-lisp-data (vstack-index data)
     358  (let* ((old (%access-lisp-data vstack-index)))
     359    (if (closed-over-value-p old)
     360      (set-closed-over-value old data)
     361      (%store-lisp-data vstack-index data))))
     362
     363
     364;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     365;;
     366;;extensions to let user access and modify values
     367
     368
     369
     370
     371
     372;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
     373
     374
     375
     376
     377
     378
     379(defparameter *saved-register-count+1*
     380  (1+ *saved-register-count*))
     381
     382
     383
     384(defparameter *saved-register-numbers*
     385  #+x8664-target #(wrong)
     386  #+ppc-target #(31 30 29 28 27 26 25 24))
     387
     388;;; Don't do unbound checks in compiled code
     389(declaim (type t *saved-register-count* *saved-register-count+1*
     390               *saved-register-names* *saved-register-numbers*))
     391
     392(defmacro %cons-saved-register-vector ()
     393  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
     394
     395(defun copy-srv (from-srv &optional to-srv)
     396  (if to-srv
     397    (if (eq from-srv to-srv)
     398      to-srv
     399      (dotimes (i (uvsize from-srv) to-srv)
     400        (setf (uvref to-srv i) (uvref from-srv i))))
     401    (copy-uvector from-srv)))
     402
     403(defmacro srv.unresolved (saved-register-vector)
     404  `(svref ,saved-register-vector 0))
     405
     406(defmacro srv.register-n (saved-register-vector n)
     407  `(svref ,saved-register-vector (1+ ,n)))
     408
     409;;; This isn't quite right - has to look at all functions on stack,
     410;;; not just those that saved VSPs.
     411
     412
     413(defun frame-restartable-p (target &optional context)
     414  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
     415    (when frame
     416      (loop
     417        (when (null frame)
     418          (return-from frame-restartable-p nil))
     419        (when (eq frame target) (return))
     420        (multiple-value-setq (frame last-catch srv)
     421          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
     422      (when (and srv (eql 0 (srv.unresolved srv)))
     423        (setf (srv.unresolved srv) last-catch)
     424        srv))))
     425
     426
     427;;; get the saved register addresses for this frame
     428;;; still need to worry about this unresolved business
     429;;; could share some code with parent-frame-saved-vars
     430(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
     431  (let ((unresolved 0))
     432    (multiple-value-bind (lfun pc) (cfp-lfun frame)
     433        (if lfun
     434          (multiple-value-bind (mask where) (registers-used-by lfun pc)
     435            (when mask
     436              (if (not where)
     437                (setq unresolved (%ilogior unresolved mask))
     438                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
     439                      (j *saved-register-count*))
     440                  (declare (fixnum j))
     441                  (dotimes (i j)
     442                    (declare (fixnum i))
     443                    (when (%ilogbitp (decf j) mask)
     444                      (setf (srv.register-n srv-out i) vsp
     445                            vsp (1+ vsp)
     446                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
     447          (setq unresolved (1- (ash 1 *saved-register-count*)))))
     448    (setf (srv.unresolved srv-out) unresolved)
     449    srv-out))
     450
     451(defun parent-frame-saved-vars
     452       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
     453  (copy-srv srv srv-out)
     454  (let* ((parent (and frame (parent-frame frame context)))
     455         (grand-parent (and parent (parent-frame parent context))))
     456    (when grand-parent
     457      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
     458              ;(declare (ignore next-catch))
     459              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
     460                (progn
     461                  (setf last-catch next-catch
     462                        (srv.unresolved srv-out) 0)
     463                  (dotimes (i *saved-register-count*)
     464                    (setf (srv.register-n srv i) nil)))
     465                (return))))
     466      (lookup-registers parent context grand-parent srv-out)
     467      (values parent last-catch srv-out))))
     468
     469(defun lookup-registers (parent context grand-parent srv-out)
     470  (unless (or (eql (frame-vsp grand-parent) 0)
     471              (let ((gg-parent (parent-frame grand-parent context)))
     472                (eql (frame-vsp gg-parent) 0)))
     473    (multiple-value-bind (lfun pc) (cfp-lfun parent)
     474      (when lfun
     475        (multiple-value-bind (mask where) (registers-used-by lfun pc)
     476          (when mask
     477            (locally (declare (fixnum mask))
     478              (if (not where)
     479                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
     480                (let* ((grand-parent-vsp (frame-vsp grand-parent)))
     481
     482                  (let ((vsp (- grand-parent-vsp where 1))
     483                        (j *saved-register-count*))
     484                    (declare (fixnum j))
     485                    (dotimes (i j)
     486                      (declare (fixnum i))
     487                      (when (%ilogbitp (decf j) mask)
     488                        (setf (srv.register-n srv-out i) vsp
     489                              vsp (1- vsp)
     490                              (srv.unresolved srv-out)
     491                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
     492
     493;;; initialization for looping on parent-frame-saved-vars
     494(defun last-catch-since-saved-vars (frame context)
     495  (let* ((parent (parent-frame frame context))
     496         (last-catch (and parent (last-catch-since parent context))))
     497    (when last-catch
     498      (let ((frame (catch-frame-sp last-catch))
     499            (srv (%cons-saved-register-vector)))
     500        (setf (srv.unresolved srv) 0)
     501        (let* ((parent (parent-frame frame context))
     502               (child (and parent (child-frame parent context))))
     503          (when child
     504            (lookup-registers child context parent srv))
     505          (values child last-catch srv))))))
     506
     507;;; Returns 2 values:
     508;;; mask srv
     509;;; The mask says which registers are used at PC in LFUN.  srv is a
     510;;; saved-register-vector whose register contents are the register
     511;;; values registers whose bits are not set in MASK or set in
     512;;; UNRESOLVED will be returned as NIL.
     513
     514(defun saved-register-values
     515       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
     516  (declare (ignore child))
     517  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
     518        ((eq srv-out srv))
     519        (t (dotimes (i (the fixnum (uvsize srv)))
     520             (setf (uvref srv-out i) (uvref srv i)))))
     521  (let ((mask (or (registers-used-by lfun pc) 0))
     522        (unresolved (srv.unresolved srv))
     523        (j *saved-register-count*))
     524    (declare (fixnum j))
     525    (dotimes (i j)
     526      (declare (fixnum i))
     527      (setf (srv.register-n srv-out i)
     528            (and (%ilogbitp (setq j (%i- j 1)) mask)
     529                 (not (%ilogbitp j unresolved))
     530                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
     531    (setf (srv.unresolved srv-out) mask)
     532    (values mask srv-out)))
     533
     534; Set the nth saved register to value.
     535(defun set-saved-register (value n lfun pc child last-catch srv)
     536  (declare (ignore lfun pc child) (dynamic-extent saved-register-values))
     537  (let ((j (- target::node-size n))
     538        (unresolved (srv.unresolved srv))
     539        (addr (srv.register-n srv n)))
     540    (when (logbitp j unresolved)
     541      (error "Can't set register ~S to ~S" n value))
     542    (set-register-value value addr last-catch j))
     543  value)
     544
     545
     546
     547
     548
     549(defun return-from-nth-frame (n &rest values)
     550  (apply-in-nth-frame n #'values values))
     551
     552(defun apply-in-nth-frame (n fn arglist)
     553  (let* ((bt-info (car *backtrace-contexts*)))
     554    (and bt-info
     555         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
     556           (and frame (apply-in-frame frame fn arglist)))))
     557  (format t "Can't return to frame ~d ." n))
     558
     559;;; This method is shadowed by one for the backtrace window.
     560(defmethod nth-frame (w target n context)
     561  (declare (ignore w))
     562  (and target (dotimes (i n target)
     563                (declare (fixnum i))
     564                (unless (setq target (parent-frame target context)) (return nil)))))
     565
     566; If this returns at all, it's because the frame wasn't restartable.
     567(defun apply-in-frame (frame fn arglist &optional context)
     568  (let* ((srv (frame-restartable-p frame context))
     569         (target-sp (and srv (srv.unresolved srv))))
     570    (if target-sp
     571      (apply-in-frame-internal context frame fn arglist srv))))
     572
     573(defun apply-in-frame-internal (context frame fn arglist srv)
     574  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
     575    (if (eq tcr (%current-tcr))
     576      (%apply-in-frame frame fn arglist srv)
     577      (let ((process (tcr->process tcr)))
     578        (if process
     579          (process-interrupt
     580           process
     581           #'%apply-in-frame
     582           frame fn arglist srv)
     583          (error "Can't find active process for ~s" tcr))))))
     584
     585
     586
     587
     588;;; (srv.unresolved srv) is the last catch frame, left there by
     589;;; frame-restartable-p The registers in srv are locations of
     590;;; variables saved between frame and that catch frame.
     591(defun %apply-in-frame (frame fn arglist srv)
     592  (declare (fixnum frame))
     593  (let* ((catch (srv.unresolved srv))
     594         (tsp-count 0)
     595         (tcr (%current-tcr))
     596         (parent (parent-frame frame tcr))
     597         (vsp (frame-vsp parent))
     598         (catch-top (%catch-top tcr))
     599         (db-link (%svref catch target::catch-frame.db-link-cell))
     600         (catch-count 0))
     601    (declare (fixnum parent vsp db-link catch-count))
     602    ;; Figure out how many catch frames to throw through
     603    (loop
     604      (unless catch-top
     605        (error "Didn't find catch frame"))
     606      (incf catch-count)
     607      (when (eq catch-top catch)
     608        (return))
     609      (setq catch-top (next-catch catch-top)))
     610    ;; Figure out where the db-link should be
     611    (loop
     612      (when (or (eql db-link 0) (>= db-link vsp))
     613        (return))
     614      (setq db-link (%fixnum-ref db-link)))
     615    ;; Figure out how many TSP frames to pop after throwing.
     616    (let ((sp (catch-frame-sp catch)))
     617      (loop
     618        (multiple-value-bind (f pc) (cfp-lfun sp)
     619          (when f (incf tsp-count (active-tsp-count f pc))))
     620        (setq sp (parent-frame sp tcr))
     621        (when (eql sp parent) (return))
     622        (unless sp (error "Didn't find frame: ~s" frame))))
     623    #+debug
     624    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
     625            catch-count srv tsp-count db-link parent fn arglist)
     626    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
     627
     628
     629
     630
     631;;;;;;;;;;;;;;;;;;;;;;;
     632;;;
     633;;; Code to determine how many tsp frames to pop.
     634;;; This is done by parsing the code.
     635;;; active-tsp-count is the entry point below.
     636;;;
     637
     638(defstruct (branch-tree (:print-function print-branch-tree))
     639  first-instruction
     640  last-instruction
     641  branch-target     ; a branch-tree or nil
     642  fall-through)     ; a branch-tree or nil
     643
     644(defun print-branch-tree (tree stream print-level)
     645  (declare (ignore print-level))
     646  (print-unreadable-object (tree stream :type t :identity t)
     647    (format stream "~s-~s"
     648            (branch-tree-first-pc tree)
     649            (branch-tree-last-pc tree))))
     650
     651(defun branch-tree-first-pc (branch-tree)
     652  (let ((first (branch-tree-first-instruction branch-tree)))
     653    (and first (instruction-element-address first))))
     654
     655(defun branch-tree-last-pc (branch-tree)
     656  (let ((last (branch-tree-last-instruction branch-tree)))
     657    (if last
     658      (instruction-element-address last)
     659      (branch-tree-first-pc branch-tree))))
     660
     661(defun branch-tree-contains-pc-p (branch-tree pc)
     662  (<= (branch-tree-first-pc branch-tree)
     663      pc
     664      (branch-tree-last-pc branch-tree)))
     665
     666(defvar *branch-tree-hash*
     667  (make-hash-table :test 'eq :weak :value))
     668
     669(defun get-branch-tree (function)
     670  (or (gethash function *branch-tree-hash*)
     671      (let* ((dll (function-to-dll-header function))
     672             (tree (dll-to-branch-tree dll)))
     673        (setf (gethash function *branch-tree-hash*) tree))))         
     674
     675; Return the number of TSP frames that will be active after throwing out
     676; of all the active catch frames in function at pc.
     677; PC is a byte address, a multiple of 4.
     678(defun active-tsp-count (function pc)
     679  (setq function
     680        (require-type
     681         (if (symbolp function)
     682           (symbol-function function)
     683           function)
     684         'compiled-function))
     685  (let* ((tree (get-branch-tree function))
     686         (visited nil))
     687    (labels ((find-pc (branch path)
     688               (unless (memq branch visited)
     689                 (push branch path)
     690                 (if (branch-tree-contains-pc-p branch pc)
     691                   path
     692                   (let ((target (branch-tree-branch-target branch))
     693                         (fall-through (branch-tree-fall-through branch)))
     694                     (push branch visited)
     695                     (if fall-through
     696                       (or (and target (find-pc target path))
     697                           (find-pc fall-through path))
     698                       (and target (find-pc target path))))))))
     699      (let* ((path (nreverse (find-pc tree nil)))
     700             (last-tree (car (last path)))
     701             (catch-count 0)
     702             (tsp-count 0))
     703        (unless path
     704          (error "Can't find path to pc: ~s in ~s" pc function))
     705        (dolist (tree path)
     706          (let ((next (branch-tree-first-instruction tree))
     707                (last (branch-tree-last-instruction tree)))
     708            (loop
     709              (when (and (eq tree last-tree)
     710                         (eql pc (instruction-element-address next)))
     711                ; If the instruction before the current one is an ff-call,
     712                ; then callback pushed a TSP frame.
     713                #| ; Not any more
     714                (when (ff-call-instruction-p (dll-node-pred next))
     715                  (incf tsp-count))
     716                |#
     717                (return))
     718              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
     719                (declare (ignore target fall-through))
     720                (case type
     721                  (:tsp-push
     722                   (when (eql catch-count 0)
     723                     (incf tsp-count count)))
     724                  (:tsp-pop
     725                   (when (eql catch-count 0)
     726                     (decf tsp-count count)))
     727                  ((:catch :unwind-protect)
     728                   (incf catch-count))
     729                  (:throw
     730                   (decf catch-count count))))
     731              (when (eq next last)
     732                (return))
     733              (setq next (dll-node-succ next)))))
     734        tsp-count))))
     735       
     736
     737(defun dll-to-branch-tree (dll)
     738  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
     739         (res (collect-branch-tree (dll-header-first dll) dll hash))
     740         (did-something nil))
     741    (loop
     742      (setq did-something nil)
     743      (let ((mapper #'(lambda (key value)
     744                        (declare (ignore key))
     745                        (flet ((maybe-collect (pc)
     746                                 (when (integerp pc)
     747                                   (let ((target-tree (gethash pc hash)))
     748                                     (if target-tree
     749                                       target-tree
     750                                       (progn
     751                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
     752                                         (setq did-something t)
     753                                         nil))))))
     754                          (declare (dynamic-extent #'maybe-collect))
     755                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
     756                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
     757                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
     758                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
     759        (declare (dynamic-extent mapper))
     760        (maphash mapper hash))
     761      (unless did-something (return)))
     762    ; To be totally correct, we should fix up the trees containing
     763    ; the BLR instruction for unwind-protect cleanups, but none
     764    ; of the users of this code yet care that it appears that the code
     765    ; stops there.
     766    res))
     767
     768(defun collect-branch-tree (instr dll hash)
     769  (unless (eq instr dll)
     770    (let ((tree (make-branch-tree :first-instruction instr))
     771          (pred nil)
     772          (next instr))
     773      (setf (gethash (instruction-element-address instr) hash)
     774            tree)
     775      (loop
     776        (when (eq next dll)
     777          (setf (branch-tree-last-instruction tree) pred)
     778          (return))
     779        (multiple-value-bind (type target fall-through) (categorize-instruction next)
     780          (case type
     781            (:label
     782             (when pred
     783               (setf (branch-tree-last-instruction tree) pred
     784                     (branch-tree-fall-through tree) (instruction-element-address next))
     785               (return)))
     786            ((:branch :catch :unwind-protect)
     787             (setf (branch-tree-last-instruction tree) next
     788                   (branch-tree-branch-target tree) target
     789                   (branch-tree-fall-through tree) fall-through)
     790             (return))))
     791        (setq pred next
     792              next (dll-node-succ next)))
     793      tree)))
     794
     795;;; Returns 4 values:
     796;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
     797;;; 2) branch target (or catch or unwind-protect cleanup)
     798;;; 3) branch-fallthrough (or catch or unwind-protect body)
     799;;; 4) Count for throw, tsp-push, tsp-pop
     800(defun categorize-instruction (instr)
     801  (etypecase instr
     802    (lap-label :label)
     803    (lap-instruction
     804     (let* ((opcode (lap-instruction-opcode instr))
     805            (opcode-p (typep opcode 'opcode))
     806            (name (if opcode-p (opcode-name opcode) opcode))
     807            (pc (lap-instruction-address instr))
     808            (operands (lap-instruction-parsed-operands instr)))
     809       (cond ((equalp name "bla")
     810              (let ((subprim (car operands)))
     811                (case subprim
     812                  (.SPmkunwind
     813                   (values :unwind-protect (+ pc 4) (+ pc 8)))
     814                  ((.SPmkcatch1v .SPmkcatchmv)
     815                   (values :catch (+ pc 4) (+ pc 8)))
     816                  (.SPthrow
     817                   (values :branch nil nil))
     818                  ((.SPnthrowvalues .SPnthrow1value)
     819                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
     820                                                    'lap-instruction))
     821                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
     822                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
     823                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
     824                     ; can't imagine we'll ever see them
     825                     (unless (and (equalp prev-name "li")
     826                                  (equalp (car prev-operands) "imm0"))
     827                       (error "Can't determine throw count for ~s" instr))
     828                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
     829                  ((.SPprogvsave
     830                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
     831                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
     832                    .SPstkconslist .SPstkconslist-star
     833                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
     834                    .SPstkvcell0 .SPstkvcellvsp
     835                    .SPsave-values)
     836                   (values :tsp-push nil nil 1))
     837                  (.SPrecover-values
     838                   (values :tsp-pop nil nil 1))
     839                  (t :regular))))
     840             ((or (equalp name "lwz") (equalp name "addi"))
     841              (if (equalp (car operands) "tsp")
     842                (values :tsp-pop nil nil 1)
     843                :regular))
     844             ((equalp name "stwu")
     845              (if (equalp (car operands) "tsp")
     846                (values :tsp-push nil nil 1)
     847                :regular))
     848             ((member name '("ba" "blr" "bctr") :test 'equalp)
     849              (values :branch nil nil))
     850             ; It would probably be faster to determine the branch address by adding the PC and the offset.
     851             ((equalp name "b")
     852              (values :branch (branch-label-address instr (car (last operands))) nil))
     853             ((and opcode-p (eql (opcode-majorop opcode) 16))
     854              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
     855             (t :regular))))))
     856
     857(defun branch-label-address (instr label-name &aux (next instr))
     858  (loop
     859    (setq next (dll-node-succ next))
     860    (when (eq next instr)
     861      (error "Couldn't find label ~s" label-name))
     862    (when (and (typep next 'lap-label)
     863               (eq (lap-label-name next) label-name))
     864      (return (instruction-element-address next)))))
     865
     866(defun dll-pc->instr (dll pc)
     867  (let ((next (dll-node-succ dll)))
     868    (loop
     869      (when (eq next dll)
     870        (error "Couldn't find pc: ~s in ~s" pc dll))
     871      (when (eql (instruction-element-address next) pc)
     872        (return next))
     873      (setq next (dll-node-succ next)))))
     874
  • branches/1.2/devel/source/lib/x86-backtrace.lisp

    r7624 r8130  
    204204  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
    205205
     206(defun exception-frame-p (x)
     207  (and x (xcf-p x)))
     208
     209;;; Function has failed a number-of-arguments check; return a list
     210;;; of the actual arguments.
     211;;; On x86-64, the kernel has finished the frame and pushed everything
     212;;; for us, so all that we need to do is to hide any inherited arguments.
     213(defun arg-check-call-arguments (fp function)
     214  (when (xcf-p fp)
     215    (with-macptrs (xp)
     216      (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp))
     217      (let* ((numinh (ldb $lfbits-numinh (lfun-bits function)))
     218             (nargs (- (xp-argument-count xp) numinh))
     219             (p (- (%fixnum-ref fp target::xcf.backptr)
     220                   (* target::node-size numinh))))
     221        (declare (fixnum numing nargs p))
     222        (collect ((args))
     223          (dotimes (i nargs (args))
     224            (args (%fixnum-ref p (- target::node-size)))
     225            (decf p)))))))
     226
    206227(defun vsp-limits (frame context)
    207228  (let* ((parent (parent-frame frame context)))
     
    224245              catch (next-catch catch))))))
    225246
     247(defun last-xcf-since (target-fp start-fp context)
     248  (do* ((last-xcf nil)
     249        (fp start-fp (parent-frame fp context)))
     250       ((or (eql fp target-fp)
     251            (null fp)
     252            (%stack< target-fp fp)) last-xcf)
     253    (if (xcf-p fp) (setq last-xcf fp))))
     254
    226255(defun match-local-name (cellno info pc)
    227256  (when info
     
    234263               (%i< pc (uvref ptrs (%i+ j 2)))
    235264               (return (aref syms i))))))))
     265
     266(defun apply-in-frame (frame function arglist &optional context)
     267  (setq function (coerce-to-function function))
     268  (let* ((parent (parent-frame frame context)))
     269    (when parent
     270      (if (xcf-p parent)
     271        (error "Can't unwind to exception frame ~s" frame)
     272        (setq frame parent))
     273      (if (or (null context)
     274              (eq (bt.tcr context) (%current-tcr)))
     275        (%apply-in-frame frame function arglist)
     276        (let* ((process (tcr->process (bt.tcr context))))
     277          (if process
     278            (process-interrupt process #'%apply-in-frame frame function arglist)
     279            (error "Can't find process for backtrace context ~s" context)))))))
     280
     281(defun return-from-frame (frame &rest values)
     282  (apply-in-frame frame #'values values nil))
     283   
     284
     285(defun last-tsp-before (target)
     286  (declare (fixnum target))
     287  (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp)
     288             (%fixnum-ref tsp target::tsp-frame.backptr)))
     289       ((zerop tsp) nil)
     290    (declare (fixnum tsp))
     291    (when (> (the fixnum (%fixnum-ref tsp target::tsp-frame.rbp))
     292             target)
     293      (return tsp))))
     294
     295   
     296
     297
     298;;; We can't determine this reliably (yet).
     299(defun last-foreign-sp-before (target)
     300  (declare (fixnum target))
     301  (do* ((cfp (%fixnum-ref (%current-tcr) target::tcr.foreign-sp)
     302             (%fixnum-ref cfp target::csp-frame.backptr)))
     303       ((zerop cfp))
     304    (declare (fixnum cfp))
     305    (let* ((rbp (%fixnum-ref cfp target::csp-frame.rbp)))
     306      (declare (fixnum rbp))
     307      (if (> rbp target)
     308        (return cfp)
     309        (if (zerop rbp)
     310          (return nil))))))
     311
     312
     313(defun %tsp-frame-containing-progv-binding (db)
     314  (declare (fixnum db))
     315  (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) next)
     316        (next (%fixnum-ref tsp target::tsp-frame.backptr)
     317              (%fixnum-ref tsp target::tsp-frame.backptr)))
     318       ()
     319    (declare (fixnum tsp next))
     320    (let* ((rbp (%fixnum-ref tsp target::tsp-frame.rbp)))
     321      (declare (fixnum rbp))
     322      (if (zerop rbp)
     323        (return (values nil nil))
     324        (if (and (> db tsp)
     325                 (< db next))
     326          (return (values tsp rbp)))))))
     327
     328       
     329
     330
     331
     332
     333(defun last-binding-before (frame)
     334  (declare (fixnum frame))
     335  (do* ((db (%current-db-link) (%fixnum-ref db 0))
     336        (tcr (%current-tcr))
     337        (vs-area (%fixnum-ref tcr target::tcr.vs-area))
     338        (vs-low (%fixnum-ref vs-area target::area.low))
     339        (vs-high (%fixnum-ref vs-area target::area.high)))
     340       ((eql db 0) nil)
     341    (declare (fixnum db vs-low vs-high))
     342    (if (and (> db vs-low)
     343             (< db vs-high))
     344      (if (> db frame)
     345        (return db))
     346      ;; db link points elsewhere; PROGV uses the temp stack
     347      ;; to store an indefinite number of bindings.
     348      (multiple-value-bind (tsp rbp)
     349          (%tsp-frame-containing-progv-binding db)
     350        (if tsp
     351          (if (> rbp frame)
     352            (return db)
     353            ;; If the tsp frame is too young, we can skip
     354            ;; all of the bindings it contains.  The tsp
     355            ;; frame contains two words of overhead, followed
     356            ;; by a count of binding records in the frame,
     357            ;; followed by the youngest of "count" binding
     358            ;; records (which happens to be the value of
     359            ;; "db".)  Skip "count" binding records.
     360            (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size)))
     361              (setq db (%fixnum-ref db 0))))
     362          ;; If the binding record wasn't on the temp stack and wasn't
     363          ;; on the value stack, that probably means that things are
     364          ;; seriously screwed up.  This error will be almost
     365          ;; meaningless to the user.
     366          (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db))))))
     367         
     368
     369
     370(defun find-x8664-saved-nvrs (frame start-fp context)
     371  (let* ((locations (make-array 16 :initial-element nil))
     372         (need (logior (ash 1 x8664::save0)
     373                       (ash 1 x8664::save1)
     374                       (ash 1 x8664::save2)
     375                       (ash 1 x8664::save3))))
     376    (declare (fixnum have need)
     377             (dynamic-extent locations))
     378    (do* ((parent frame child)
     379          (child (child-frame parent context) (child-frame child context)))
     380         ((or (= need 0) (eq child start-fp))
     381          (values (%svref locations x8664::save0)
     382                  (%svref locations x8664::save1)
     383                  (%svref locations x8664::save2)
     384                  (%svref locations x8664::save3)))
     385      (multiple-value-bind (lfun pc) (cfp-lfun child)
     386        (when (and lfun pc)
     387          (multiple-value-bind (used where) (registers-used-by lfun pc)
     388            (when (and used where (logtest used need))
     389              (locally (declare (fixnum used))
     390                (do* ((i x8664::save3 (1+ i)))
     391                     ((or (= i 16) (= used 0)))
     392                  (declare (type (mod 16) i))
     393                  (when (logbitp i used)
     394                    (when (logbitp i need)
     395                      (setq need (logandc2 need (ash 1 i)))
     396                      (setf (%svref locations i)
     397                            (- (the fixnum (1- parent))
     398                               (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i)))))))))
     399                    (setq used (logandc2 used (ash 1 i)))))))))))))
     400                                         
     401             
     402         
     403(defun %apply-in-frame (frame function arglist)
     404  (let* ((target-catch (last-catch-since frame nil))
     405         (start-fp (if target-catch
     406                     (uvref target-catch target::catch-frame.rbp-cell)
     407                     (%get-frame-ptr)))
     408         (target-xcf (last-xcf-since frame start-fp nil))
     409         (target-db-link (last-binding-before frame))
     410         (target-tsp (last-tsp-before frame))
     411         (target-foreign-sp (last-foreign-sp-before frame)))
     412    (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc)
     413        (find-x8664-saved-nvrs frame start-fp nil)
     414      (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto
     415                                         frame
     416                                         target-catch
     417                                         target-db-link
     418                                         target-xcf
     419                                         target-tsp
     420                                         target-foreign-sp
     421                                         (if save0-loc
     422                                           (- save0-loc frame)
     423                                           0)
     424                                         (if save1-loc
     425                                           (- save1-loc frame)
     426                                           0)
     427                                         (if save2-loc
     428                                           (- save2-loc frame)
     429                                           0)
     430                                         (if save3-loc
     431                                           (- save3-loc frame)
     432                                           0)
     433                                         (coerce-to-function function)
     434                                         arglist
     435                                         0)))
     436        (funcall thunk)))))
     437
     438           
     439   
  • branches/1.2/devel/source/lisp-kernel/x86-constants64.h

    r7828 r8130  
    330330  LispObj xp;                   /* exception context */
    331331  LispObj ra0;                  /* value of ra0 from context */
     332  LispObj foreign_sp;           /* foreign sp at the time that exception occurred */
     333  LispObj prev_xframe;          /* so %apply-in-frame can unwind it */
    332334} xcf;
    333335
  • branches/1.2/devel/source/lisp-kernel/x86-constants64.s

    r7624 r8130  
    382382        _struct(tsp_frame,0)
    383383         _node(backlink)
    384          _node(type)
     384         _node(save_rbp)
    385385         _struct_label(fixed_overhead)
    386386         _struct_label(data_offset)
    387387        _ends
    388388
     389        _struct(csp_frame,0)
     390         _node(backlink)
     391         _node(save_rbp)
     392         _struct_label(fixed_overhead)
     393         _struct_label(data_offset)
     394        _ends
     395       
    389396
    390397
  • branches/1.2/devel/source/lisp-kernel/x86-exceptions.c

    r7979 r8130  
    276276  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp), ra = *vsp++;
    277277   
    278  
     278  xpGPR(xp,Isp) = (LispObj) vsp;
     279
    279280  if (disp > 0) {               /* implies that nargs > 3 */
    280281    vsp[disp] = xpGPR(xp,Irbp);
    281282    vsp[disp+1] = ra;
    282283    xpGPR(xp,Irbp) = (LispObj)(vsp+disp);
    283     xpGPR(xp,Isp) = (LispObj)vsp;
    284284    push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
    285285    push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
     
    315315
    316316LispObj
    317 create_exception_callback_frame(ExceptionInformation *xp)
     317create_exception_callback_frame(ExceptionInformation *xp, TCR *tcr)
    318318{
    319319  LispObj containing_uvector = 0,
     
    370370    relative_pc = abs_pc << fixnumshift;
    371371  }
    372  
     372  push_on_lisp_stack(xp,(LispObj)(tcr->xframe->prev));
     373  push_on_lisp_stack(xp,(LispObj)(tcr->foreign_sp));
    373374  push_on_lisp_stack(xp,tra);
    374375  push_on_lisp_stack(xp,(LispObj)xp);
     
    408409 
    409410  {
    410     LispObj xcf = create_exception_callback_frame(xp),
     411    LispObj xcf = create_exception_callback_frame(xp, tcr),
    411412      cmain = nrs_CMAIN.vcell;
    412413    int skip;
     
    458459    *save_vsp = (LispObj *)xpGPR(xp,Isp),
    459460    word_beyond_vsp = save_vsp[-1],
    460     xcf = create_exception_callback_frame(xp);
     461    xcf = create_exception_callback_frame(xp, tcr);
    461462  int save_errno = errno;
    462463 
     
    483484      finish_function_entry(xp);
    484485    }
    485     xcf0 = create_exception_callback_frame(xp);
     486    xcf0 = create_exception_callback_frame(xp, tcr);
    486487    skip = callback_to_lisp(tcr, errdisp, xp, xcf0, 0, 0, 0, 0);
    487488    if (skip == -1) {
     
    591592    soft = a->softprot;
    592593    unprotect_area(soft);
    593     xcf = create_exception_callback_frame(xp);
     594    xcf = create_exception_callback_frame(xp, tcr);
    594595    skip = callback_to_lisp(tcr, nrs_CMAIN.vcell, xp, xcf, SIGSEGV, on_TSP, 0, 0);
    595596    xpGPR(xp,Irbp) = save_rbp;
     
    642643    if ((fulltag_of(cmain) == fulltag_misc) &&
    643644      (header_subtag(header_of(cmain)) == subtag_macptr)) {
    644       xcf = create_exception_callback_frame(xp);
     645      xcf = create_exception_callback_frame(xp, tcr);
    645646      callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, is_write_fault(xp,info), (natural)addr, 0);
    646647    }
     
    660661  if ((fulltag_of(cmain) == fulltag_misc) &&
    661662      (header_subtag(header_of(cmain)) == subtag_macptr)) {
    662     xcf = create_exception_callback_frame(xp);
     663    xcf = create_exception_callback_frame(xp, tcr);
    663664    skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0);
    664665    xpPC(xp) += skip;
  • branches/1.2/devel/source/lisp-kernel/x86-macros.s

    r6529 r8130  
    128128        zero_dnodes $2,0,TSP_Alloc_Size
    129129        movq %stack_temp,($2)
     130        movq %rbp,tsp_frame.save_rbp($2)
    130131        movq $2,%rcontext:tcr.save_tsp
    131132        undefine([TSP_Alloc_Size])
     
    150151        movd %stack_temp,$1
    151152        movq $1,($2)
     153        movq %rbp,tsp_frame.save_rbp($2)
    152154        movq $2,%rcontext:tcr.save_tsp
    153155        addq $dnode_size,$2
  • branches/1.2/devel/source/lisp-kernel/x86-spentry64.s

    r7960 r8130  
    20522052        __(jnz 0b)     
    20532053        __(movq %stack_temp,(%temp0))
    2054         __(movq %imm0,tsp_frame.fixed_overhead(%temp0))
    2055         __(leaq tsp_frame.fixed_overhead+fulltag_misc(%temp0),%arg_z)
     2054        __(movq %rbp,csp_frame.save_rbp(%temp0))
     2055        __(movq %imm0,csp_frame.fixed_overhead(%temp0))
     2056        __(leaq csp_frame.fixed_overhead+fulltag_misc(%temp0),%arg_z)
    20562057        __(ret)
    20572058local_label(stack_misc_alloc_heap_alloc_ivector):
     
    26682669        __(movq %rcontext:tcr.foreign_sp,%arg_z)
    26692670        __(movq %imm1,(%arg_z))
     2671        __(movq %rbp,csp_frame.save_rbp(%arg_z))
    26702672        __(lea macptr.size+tsp_frame.fixed_overhead(%arg_z),%imm0)
    26712673        __(movq $macptr_header,tsp_frame.fixed_overhead(%arg_z))
     
    26792681        __(movq %rcontext:tcr.foreign_sp,%imm0)
    26802682        __(movq %imm1,(%imm0))
     2683        __(movq %rbp,csp_frame.save_rbp(%imm0))
    26812684        __(set_nargs(1))
    26822685        __(movq $nrs.new_gcable_ptr,%fname)
     
    26932696        __(movq %rcontext:tcr.foreign_sp,%arg_z)
    26942697        __(movq %imm1,(%arg_z))
     2698        __(movq %rbp,csp_frame.save_rbp(%arg_z))
    26952699        __(lea macptr.size+tsp_frame.fixed_overhead(%arg_z),%imm0)
    26962700        __(movq $macptr_header,tsp_frame.fixed_overhead(%arg_z))
     
    27092713        __(movq %rcontext:tcr.foreign_sp,%imm0)
    27102714        __(movq %imm1,(%imm0))
     2715        __(movq %rbp,csp_frame.save_rbp(%imm0))
    27112716        __(set_nargs(1))
    27122717        __(movq $nrs.new_gcable_ptr,%fname)
     
    45224527        __(movq %r12,%r11)
    452345281:      /* Align foreign stack for lisp   */
    4524         __(subq $node_size,%rsp)
     4529        __(pushq %rcontext:tcr.save_rbp) /* mark cstack frame's "owner" */
    45254530        __(pushq %rcontext:tcr.foreign_sp)
    45264531        /* init lisp registers   */
  • branches/1.2/devel/source/lisp-kernel/x86-subprims64.s

    r6523 r8130  
    3535        __(movq %rsp,%rbp)
    3636        /* Switch to the lisp stack */
     37        __(push $0)
     38        __(push $0)
    3739        __(movq %rsp,%rcontext:tcr.foreign_sp)
    3840        __(movq %rcontext:tcr.save_vsp,%rsp)
    3941        __(push $0)
    4042        __(movq %rsp,%rbp)
     43       
     44        __(TSP_Alloc_Fixed(0,%temp0))
     45        __(movsd %fpzero,tsp_frame.save_rbp(%temp0)) /* sentinel */
    4146        __(jmp local_label(test))
    4247local_label(loop):
     
    6166        __(jnz local_label(loop))
    6267local_label(back_to_c):
     68        __(discard_temp_frame(%imm0))
    6369        __(movq %rcontext:tcr.foreign_sp,%rsp)
     70        __(addq $dnode_size,%rsp)
    6471        __(movq %rsp,%rbp)
    6572        __(leave)
Note: See TracChangeset for help on using the changeset viewer.