losp/muerte/functions.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      functions.lisp
   9 ;;;; Description:   Misc. function-oriented functions
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Tue Mar 12 22:58:54 2002
  12 ;;;;
  13 ;;;; $Id: functions.lisp,v 1.31 2006/05/02 20:01:46 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (require :muerte/setf)
  19 (provide :muerte/functions)
  20
  21 (in-package muerte)
  22
  23 (defvar *setf-namespace* nil
  24   "This hash-table is initialized by dump-image.")
  25
  26 (defun identity (x) x)
  27
  28 (defun constantly-prototype (&rest ignore)
  29   (declare (ignore ignore))
  30   'value)
  31
  32 (defun constantly-true (&rest ignore)
  33   (declare (ignore ignore))
  34   t)
  35
  36 (defun constantly-false (&rest ignore)
  37   (declare (ignore ignore))
  38   nil)
  39
  40 (define-compiler-macro constantly (&whole form value-form &environment env)
  41   (cond
  42    ((movitz:movitz-constantp value-form env)
  43     (let ((value (movitz:movitz-eval value-form env)))
  44       (case (translate-program value :muerte.cl :cl)
  45         ((t) `(function constantly-true))
  46         ((nil) `(function constantly-false))
  47         (t form))))
  48    (t form)))
  49
  50 (defun constantly (x)
  51   (lambda () x))
  52
  53 (defun complement-prototype (&rest args)
  54   (declare (dynamic-extent args))
  55   (not (apply 'function args)))
  56
  57 (define-compiler-macro complement (&whole form function-form &environment env)
  58   (cond
  59    ((and (listp function-form)
  60          (eq 'function (first function-form))
  61          (typep (movitz:movitz-eval (translate-program function-form :cl :muerte.cl) env)
  62                 'movitz:movitz-funobj))
  63     `(make-prototyped-function `(complement ,(second function-form))
  64                                complement-prototype
  65                                ,(movitz:movitz-eval (translate-program function-form :cl :muerte.cl))))
  66    (t form)))
  67
  68 (defun complement (function)
  69   (lambda (&rest args)
  70     (declare (dynamic-extent args))
  71     (not (apply function args))))
  72
  73 (defun unbound-function (&edx edx &rest args)
  74   "This is the function that is the unbound value for function cells."
  75   (declare (dynamic-extent args))
  76   (let ((function-name (typecase edx
  77                          (symbol
  78                           edx)
  79                          (compiled-function
  80                           (funobj-name edx))
  81                          (t '(unknown)))))
  82     (with-simple-restart (continue "Return NIL from ~S." function-name)
  83       (error 'undefined-function-call
  84              :name function-name
  85              :arguments (copy-list args))))
  86   nil)
  87
  88 ;;; funobj object
  89
  90 (defun funobj-type (funobj)
  91   (check-type funobj function)
  92   (with-inline-assembly (:returns :untagged-fixnum-ecx)
  93     (:xorl :ecx :ecx)
  94     (:compile-form (:result-mode :eax) funobj)
  95     (:movb (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:funobj-type)) :cl)))
  96
  97 (defun funobj-code-vector (funobj)
  98   (check-type funobj function)
  99   (memref funobj (movitz-type-slot-offset 'movitz-funobj 'code-vector)
 100           :type :code-vector))
 101
 102 (defun (setf funobj-code-vector) (code-vector funobj)
 103   (check-type funobj function)
 104   (check-type code-vector code-vector)
 105   (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'code-vector)
 106                 :type :code-vector)
 107     code-vector))
 108
 109 (defun funobj-code-vector%1op (funobj)
 110   "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either
 111 a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely.
 112 The former is represented as a lisp integer that is the index into the code-vector, the latter is
 113 represented as that vector."
 114   (check-type funobj function)
 115   (with-inline-assembly (:returns :eax)
 116     ;; Set up atomically continuation.
 117     (:declare-label-set restart-jumper (retry))
 118     (:locally (:pushl (:edi (:edi-offset :dynamic-env))))
 119     (:pushl 'restart-jumper)
 120     ;; ..this allows us to detect recursive atomicallies.
 121     (:locally (:pushl (:edi (:edi-offset :atomically-continuation))))
 122     (:pushl :ebp)
 123    retry
 124
 125     (:movl (:esp) :ebp)
 126     (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 127     ;; Now inside atomically section.
 128
 129     (:compile-form (:result-mode :ebx) funobj)
 130     (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector
 131     (:movl (:ebx (:offset movitz-funobj code-vector%1op)) :ecx)
 132     ;; determine if ECX is a pointer into EAX
 133     (:subl :eax :ecx)
 134     (:jl 'return-vector)
 135     (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :ecx)
 136     (:cmpl (:eax (:offset movitz-basic-vector num-elements -2)) :ecx)
 137     (:jnc 'return-vector)
 138     ;; return the integer offset
 139     (:movl :ecx :eax)
 140     (:jmp 'done)
 141    return-vector
 142     (:testl 7 (:ebx (:offset movitz-funobj code-vector%1op)))
 143     (:jnz '(:sub-program () (:int 63)))
 144     (:movl #xfffffffe :eax)
 145     (:addl (:ebx (:offset movitz-funobj code-vector%1op)) :eax)
 146    done
 147     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 148     (:leal (:esp 16) :esp)))
 149
 150 (defun (setf funobj-code-vector%1op) (code-vector funobj)
 151   (check-type funobj function)
 152   (etypecase code-vector
 153     (code-vector
 154      (with-inline-assembly (:returns :nothing)
 155        (:compile-form (:result-mode :ebx) funobj)
 156        (:compile-form (:result-mode :eax) code-vector)
 157        (:addl 2 :eax)                   ; this cell stores word+2
 158        (:movl :eax (:ebx (:offset movitz-funobj code-vector%1op)))))
 159     (integer
 160      (with-inline-assembly (:returns :nothing)
 161        (:compile-form (:result-mode :ebx) funobj)
 162        (:movl (:ebx (:offset movitz-funobj code-vector)) :eax)
 163        (:movl :eax (:ebx (:offset movitz-funobj code-vector%1op)))
 164        (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector)
 165        (:addl :ecx (:ebx (:offset movitz-funobj code-vector%1op))))))
 166   code-vector)
 167
 168 (defun funobj-code-vector%2op (funobj)
 169   "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either
 170 a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely.
 171 The former is represented as a lisp integer that is the index into the code-vector, the latter is
 172 represented as that vector."
 173   (check-type funobj function)
 174   (with-inline-assembly (:returns :eax)
 175     ;; Set up atomically continuation.
 176     (:declare-label-set restart-jumper (retry))
 177     (:locally (:pushl (:edi (:edi-offset :dynamic-env))))
 178     (:pushl 'restart-jumper)
 179     ;; ..this allows us to detect recursive atomicallies.
 180     (:locally (:pushl (:edi (:edi-offset :atomically-continuation))))
 181     (:pushl :ebp)
 182    retry
 183     (:movl (:esp) :ebp)
 184     (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 185     ;; Now inside atomically section.
 186
 187     (:compile-form (:result-mode :ebx) funobj)
 188     (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector
 189     (:movl (:ebx (:offset movitz-funobj code-vector%2op)) :ecx)
 190     ;; determine if ECX is a pointer into EAX
 191     (:subl :eax :ecx)
 192     (:jl 'return-vector)
 193     (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :ecx)
 194     (:cmpl (:eax (:offset movitz-basic-vector num-elements -2)) :ecx)
 195     (:jnc 'return-vector)
 196     ;; return the integer offset EAX-EBX
 197     (:movl :ecx :eax)
 198     (:jmp 'done)
 199    return-vector
 200     (:testl 7 (:ebx (:offset movitz-funobj code-vector%2op)))
 201     (:jnz '(:sub-program () (:int 63)))
 202     (:movl #xfffffffe :eax)
 203     (:addl (:ebx (:offset movitz-funobj code-vector%2op)) :eax)
 204    done
 205     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 206     (:leal (:esp 16) :esp)))
 207
 208 (defun (setf funobj-code-vector%2op) (code-vector funobj)
 209   (check-type funobj function)
 210   (etypecase code-vector
 211     (code-vector
 212      (with-inline-assembly (:returns :nothing)
 213        (:compile-form (:result-mode :ebx) funobj)
 214        (:compile-form (:result-mode :eax) code-vector)
 215        (:addl 2 :eax)                   ; this cell stores word+2
 216        (:movl :eax (:ebx (:offset movitz-funobj code-vector%2op)))))
 217     (integer
 218      (with-inline-assembly (:returns :nothing)
 219        (:compile-form (:result-mode :ebx) funobj)
 220        (:movl (:ebx (:offset movitz-funobj code-vector)) :eax)
 221        (:movl :eax (:ebx (:offset movitz-funobj code-vector%2op)))
 222        (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector)
 223        (:addl :ecx (:ebx (:offset movitz-funobj code-vector%2op))))))
 224   code-vector)
 225
 226 (defun funobj-code-vector%3op (funobj)
 227   "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either
 228 a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely.
 229 The former is represented as a lisp integer that is the index into the code-vector, the latter is
 230 represented as that vector."
 231   (check-type funobj function)
 232   (with-inline-assembly (:returns :eax)
 233     ;; Set up atomically continuation.
 234     (:declare-label-set restart-jumper (retry))
 235     (:locally (:pushl (:edi (:edi-offset :dynamic-env))))
 236     (:pushl 'restart-jumper)
 237     ;; ..this allows us to detect recursive atomicallies.
 238     (:locally (:pushl (:edi (:edi-offset :atomically-continuation))))
 239     (:pushl :ebp)
 240    retry
 241     (:movl (:esp) :ebp)
 242     (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 243     ;; Now inside atomically section.
 244
 245     (:compile-form (:result-mode :ebx) funobj)
 246     (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector
 247     (:movl (:ebx (:offset movitz-funobj code-vector%3op)) :ecx)
 248     ;; determine if ECX is a pointer into EAX
 249     (:subl :eax :ecx)
 250     (:jl 'return-vector)
 251     (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :ecx)
 252     (:cmpl (:eax (:offset movitz-basic-vector num-elements -2)) :ecx)
 253     (:jnc 'return-vector)
 254     ;; return the integer offset EAX-EBX
 255     (:movl :ecx :eax)
 256     (:jmp 'done)
 257    return-vector
 258     (:testl 7 (:ebx (:offset movitz-funobj code-vector%3op)))
 259     (:jnz '(:sub-program () (:int 63)))
 260     (:movl #xfffffffe :eax)
 261     (:addl (:ebx (:offset movitz-funobj code-vector%3op)) :eax)
 262    done
 263     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 264     (:leal (:esp 16) :esp)))
 265
 266 (defun (setf funobj-code-vector%3op) (code-vector funobj)
 267   (check-type funobj function)
 268   (etypecase code-vector
 269     (code-vector
 270      (with-inline-assembly (:returns :nothing)
 271        (:compile-form (:result-mode :ebx) funobj)
 272        (:compile-form (:result-mode :eax) code-vector)
 273        (:addl 2 :eax)                   ; this cell stores word+2
 274        (:movl :eax (:ebx (:offset movitz-funobj code-vector%3op)))))
 275     (integer
 276      (with-inline-assembly (:returns :nothing)
 277        (:compile-form (:result-mode :ebx) funobj)
 278        (:movl (:ebx (:offset movitz-funobj code-vector)) :eax)
 279        (:movl :eax (:ebx (:offset movitz-funobj code-vector%3op)))
 280        (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector)
 281        (:addl :ecx (:ebx (:offset movitz-funobj code-vector%3op))))))
 282   code-vector)
 283
 284 (defun funobj-name (funobj)
 285   (check-type funobj function)
 286   (memref funobj (movitz-type-slot-offset 'movitz-funobj 'name)))
 287
 288 (defun (setf funobj-name) (name funobj)
 289   (check-type funobj function)
 290   (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'name))
 291     name))
 292
 293 (defun funobj-lambda-list (funobj)
 294   (check-type funobj function)
 295   (memref funobj (movitz-type-slot-offset 'movitz-funobj 'lambda-list)))
 296
 297 (defun (setf funobj-lambda-list) (lambda-list funobj)
 298   (check-type funobj function)
 299   (check-type lambda-list list)
 300   (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'lambda-list))
 301     lambda-list))
 302
 303 (defun funobj-num-constants (funobj)
 304   (check-type funobj function)
 305   (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-constants)
 306           :type :unsigned-byte16))
 307
 308 (defun (setf funobj-num-constants) (num-constants funobj)
 309   (check-type funobj function)
 310   (check-type num-constants (unsigned-byte 16))
 311   (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-constants)
 312                 :type :unsigned-byte16)
 313     num-constants))
 314
 315 (defun funobj-num-jumpers (funobj)
 316   (check-type funobj function)
 317   (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-jumpers)
 318           :type :unsigned-byte14))
 319
 320 (defun (setf funobj-num-jumpers) (num-jumpers funobj)
 321   (check-type funobj function)
 322   (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-jumpers)
 323                 :type :unsigned-byte14)
 324     num-jumpers)
 325   #+ignore
 326   (with-inline-assembly (:returns :eax)
 327     (:compile-two-forms (:eax :ebx) num-jumpers funobj)
 328     (:movw :ax (:ebx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)))))
 329
 330 (defun funobj-constant-ref (funobj index)
 331   (check-type funobj function)
 332   (assert (below index (funobj-num-constants funobj)) (index)
 333     "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj))
 334   (if (>= index (funobj-num-jumpers funobj))
 335       (memref funobj (movitz-type-slot-offset 'movitz-funobj 'constant0) :index index)
 336     ;; For a jumper, return its offset relative to the code-vector.
 337     ;; This is tricky wrt. to potential GC interrupts, because we're doing
 338     ;; pointer arithmetics.
 339     (with-inline-assembly (:returns :eax)
 340       (:compile-two-forms (:eax :ecx) funobj index)
 341       (:movl #.movitz:+code-vector-transient-word+ :ebx)
 342       (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))
 343              :ebx)                      ; code-vector (word) into ebx
 344       (:subl (:eax :ecx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))
 345              :ebx)
 346       (:negl :ebx)
 347       (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax))))
 348
 349 (defun (setf funobj-constant-ref) (value funobj index)
 350   (check-type funobj function)
 351   (assert (below index (funobj-num-constants funobj)) (index)
 352     "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj))
 353   (if (>= index (funobj-num-jumpers funobj))
 354       (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'constant0) :index index)
 355         value)
 356     (progn
 357       (assert (below value (length (funobj-code-vector funobj))) (value)
 358         "The jumper value ~D is invalid because the code-vector's size is ~D."
 359         value (length (funobj-code-vector funobj)))
 360       (progn ;; XXX without-gc
 361        (with-inline-assembly (:returns :nothing)
 362          (:compile-two-forms (:eax :edx) funobj index)
 363          (:compile-form (:result-mode :ecx) value)
 364          (:movl #.movitz:+code-vector-transient-word+ :ebx)
 365          (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))
 366                 :ebx)                   ; code-vector (word) into ebx
 367          (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) ; value
 368          (:movl :ecx (:eax :edx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
 369          (:addl :ebx (:eax :edx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))))
 370       value)))
 371
 372 (defun funobj-debug-info (funobj)
 373   (check-type funobj function)
 374   (memref funobj (movitz-type-slot-offset 'movitz-funobj 'debug-info) :type :unsigned-byte16))
 375
 376 (defun funobj-frame-raw-locals (funobj)
 377   "The number of unboxed slots in this function's stack-frame(s)."
 378   (declare (ignore funobj))
 379   0)
 380
 381 (defun funobj-frame-headers-p (funobj)
 382   "Can this function place header-vals in its stack-frame?"
 383   (declare (ignore funobj))
 384   t)
 385
 386 (defun make-funobj (&key (name :unnamed)
 387                          (code-vector (funobj-code-vector #'constantly-prototype))
 388                          (constants nil)
 389                          lambda-list)
 390   (setf code-vector
 391     (etypecase code-vector
 392       (code-vector code-vector)
 393       (list
 394        (make-array (length code-vector)
 395                    :element-type 'code
 396                    :initial-contents code-vector))
 397       (vector
 398        (make-array (length code-vector)
 399                    :element-type 'code
 400                    :initial-contents code-vector))))
 401   (let* ((num-constants (length constants))
 402          (funobj (macrolet
 403                      ((do-it ()
 404                         `(with-allocation-assembly ((+ num-constants
 405                                                        ,(movitz::movitz-type-word-size 'movitz-funobj))
 406                                                     :object-register :eax
 407                                                     :size-register :ecx)
 408                            (:movl ,(movitz:tag :funobj) (:eax ,movitz:+other-type-offset+))
 409                            (:load-lexical (:lexical-binding num-constants) :edx)
 410                            (:movl :edx :ecx)
 411                            (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ecx)
 412                            (:movl :ecx (:eax (:offset movitz-funobj num-jumpers)))
 413                            (:xorl :ecx :ecx)
 414                            (:xorl :ebx :ebx)
 415                            (:testl :edx :edx)
 416                            (:jmp 'init-done)
 417                            init-loop
 418                            (:movl :ecx (:eax :ebx ,movitz:+other-type-offset+))
 419                            (:addl 4 :ebx)
 420                            (:cmpl :ebx :edx)
 421                            (:ja 'init-loop)
 422                            init-done
 423                            (:leal (:edx ,(bt:sizeof 'movitz:movitz-funobj)) :ecx))))
 424                    (do-it))))
 425     (setf (funobj-name funobj) name
 426           (funobj-code-vector funobj) code-vector
 427           ;; revert to default trampolines for now..
 428           (funobj-code-vector%1op funobj) (symbol-value 'trampoline-funcall%1op)
 429           (funobj-code-vector%2op funobj) (symbol-value 'trampoline-funcall%2op)
 430           (funobj-code-vector%3op funobj) (symbol-value 'trampoline-funcall%3op)
 431           (funobj-lambda-list funobj) lambda-list)
 432     (do* ((i 0 (1+ i))
 433           (p constants (cdr p))
 434           (x (car p)))
 435         ((endp p))
 436       (setf (funobj-constant-ref funobj i) x))
 437     funobj))
 438
 439
 440 (defun install-function (name constants code-vector)
 441   (let ((funobj (make-funobj :name name :constants constants :code-vector code-vector)))
 442     (warn "installing ~S for ~S.." funobj name)
 443     (setf (symbol-function name) funobj)))
 444
 445 (defun replace-funobj (dst src &optional (name (funobj-name src)))
 446   "Copy each element of src to dst. Dst's num-constants must be initialized,
 447 so that we can be reasonably sure of dst's size."
 448   (assert (= (funobj-num-constants src)
 449              (funobj-num-constants dst)))
 450   (setf (funobj-name dst) name
 451         (funobj-num-jumpers dst) (funobj-num-jumpers src)
 452         (funobj-code-vector dst) (funobj-code-vector src)
 453         (funobj-code-vector%1op dst) (funobj-code-vector%1op src)
 454         (funobj-code-vector%2op dst) (funobj-code-vector%2op src)
 455         (funobj-code-vector%3op dst) (funobj-code-vector%3op src)
 456         (funobj-lambda-list dst) (funobj-lambda-list src))
 457   (dotimes (i (funobj-num-constants src))
 458     (setf (funobj-constant-ref dst i)
 459       (funobj-constant-ref src i)))
 460   dst)
 461
 462 (defun copy-funobj (old-funobj)
 463   (check-type old-funobj function)
 464   (%shallow-copy-object old-funobj
 465                         (+ (funobj-num-constants old-funobj)
 466                            (movitz-type-word-size 'movitz-funobj))))
 467
 468 (defun install-funobj-name (name funobj)
 469   (setf (funobj-name funobj) name)
 470   funobj)
 471
 472 (defun fdefinition (function-name)
 473   (etypecase function-name
 474     (symbol
 475      (symbol-function function-name))
 476     ((cons (eql setf))
 477      (symbol-function (gethash (cadr function-name) *setf-namespace*)))))
 478
 479 (defun (setf fdefinition) (value function-name)
 480   (etypecase function-name
 481     (symbol
 482      (setf (symbol-function function-name) value))
 483     ((cons (eql setf))
 484      (let* ((setf-name (cadr function-name))
 485             (setf-symbol (or (gethash setf-name *setf-namespace*)
 486                              (setf (gethash setf-name *setf-namespace*)
 487                                (make-symbol (format nil "~A-~A" 'setf 'setf-name))))))
 488        (setf (symbol-function setf-symbol)
 489          value)))))
 490
 491 (defun fmakunbound (function-name)
 492   (setf (fdefinition function-name)
 493     (load-global-constant unbound-function)))