;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;; Copyright 1994-2009 Clozure Associates
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package "CCL")

;;; It's easier to keep this is LAP; we want to play around with its
;;; constants.

;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL.
;;; The map is a vector of (UNSIGNED-BYTE 8); this should
;;; be used when there are less than 255 slots in the class.
(defppclapfunction %small-map-slot-id-lookup ((slot-id arg_z))
  (ldr temp1 'map nfn)
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (header-length imm3 imm0)
  (ldr temp0 'table nfn)
  (cmplr arg_x imm3)
  (srri imm0 arg_x target::word-shift)
  (la imm0 target::misc-data-offset imm0)
  (li imm1 target::misc-data-offset)
  (bge @have-scaled-table-index)
  (lbzx imm1 temp1 imm0)
  (slri imm1 imm1 target::word-shift)
  (la imm1 target::misc-data-offset imm1)
  @have-scaled-table-index
  (ldrx arg_z temp0 imm1)
  (blr))

;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32).
(defppclapfunction %large-map-slot-id-lookup ((slot-id arg_z))
  (ldr temp1 'map nfn)
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (header-length imm3 imm0)
  (ldr temp0 'table nfn)
  (cmplr arg_x imm3)
  #+ppc64-target
  (progn
    (srdi imm0 imm0 1)
    (la imm0 target::misc-data-offset imm0))
  #+pp32-target
  (progn
    (la imm0 target::misc-data-offset arg_x))
  (li imm1 target::misc-data-offset)
  (bge @have-scaled-table-index)
  (lwzx imm1 temp1 imm0)
  (slri imm1 imm1 target::word-shift)
  (la imm1 target::misc-data-offset imm1)
  @have-scaled-table-index
  (ldrx arg_z temp0 imm1)
  (blr))

(defppclapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z))
  (ldr temp1 'map nfn)
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (ldr temp0 'table nfn)
  (header-length imm3 imm0)
  (cmplr arg_x imm3)
  (srri imm0 arg_x target::word-shift)
  (la imm0 target::misc-data-offset imm0)
  (bge @missing)
  (lbzx imm1 temp1 imm0)
  (cmpri imm1 0)
  (slri imm1 imm1 target::word-shift)
  (la imm1 target::misc-data-offset imm1)
  (beq @missing)
  (ldrx arg_z temp0 imm1)
  (ldr arg_x 'class nfn)
  (ldr nfn '%maybe-std-slot-value nfn)
  (ldr temp0 target::misc-data-offset nfn)
  (set-nargs 3)
  (mtctr temp0)
  (bctr)
  @missing                              ; (%slot-id-ref-missing instance id)
  (ldr nfn '%slot-id-ref-missing nfn)
  (set-nargs 2)
  (ldr temp0 target::misc-data-offset nfn)
  (mtctr temp0)
  (bctr))

(defppclapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z))
  (ldr temp1 'map nfn)
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (ldr temp0 'table nfn)
  (header-length imm3 imm0)
  (cmplr arg_x imm3)
  #+ppc64-target
  (progn
    (srdi imm0 arg_x 1)
    (la imm0 target::misc-data-offset imm0))
  #+ppc32-target
  (progn
    (la imm0 target::misc-data-offset arg_x))
  (bge @missing)
  (lwzx imm1 temp1 imm0)
  (cmpri imm1 0)
  (slri imm1 imm1 target::word-shift)
  (la imm1 target::misc-data-offset imm1)
  (beq @missing)
  @have-scaled-table-index
  (ldr arg_x 'class nfn)
  (ldr nfn '%maybe-std-slot-value-using-class nfn)
  (ldrx arg_z temp0 imm1)
  (ldr temp0 target::misc-data-offset nfn)
  (set-nargs 3)
  (mtctr temp0)
  (bctr)
  @missing                              ; (%slot-id-ref-missing instance id)
  (ldr nfn '%slot-id-ref-missing nfn)
  (set-nargs 2)
  (ldr temp0 target::misc-data-offset nfn)
  (mtctr temp0)
  (bctr))
  
(defppclapfunction %small-set-slot-id-value ((instance arg_x)
                                             (slot-id arg_y)
                                             (new-value arg_z))
  (ldr temp1 'map nfn)
  (svref imm3 slot-id.index slot-id)
  (getvheader imm0 temp1)
  (ldr temp0 'table nfn)
  (header-length imm5 imm0)
  (cmplr imm3 imm5)
  (srri imm0 imm3 target::word-shift)
  (la imm0 target::misc-data-offset imm0)
  (bge @missing)
  (lbzx imm1 temp1 imm0)
  (cmpwi imm1 0)
  (slri imm1 imm1 target::word-shift)
  (la imm1 target::misc-data-offset imm1)
  (beq @missing)
  @have-scaled-table-index
  (ldr temp1 'class nfn)
  (ldrx arg_y temp0 imm1)
  (ldr nfn '%maybe-std-setf-slot-value-using-class nfn)
  (set-nargs 4)
  (ldr temp0 target::misc-data-offset nfn)
  (vpush temp1)
  (mtctr temp0)
  (bctr)
  @missing                              ; (%slot-id-set-missing instance id new-value)
  (ldr nfn '%slot-id-set-missing nfn)
  (set-nargs 3)
  (ldr temp0 target::misc-data-offset nfn)
  (mtctr temp0)
  (bctr))

(defppclapfunction %large-set-slot-id-value ((instance arg_x)
                                             (slot-id arg_y)
                                             (new-value arg_z))
  (ldr temp1 'map nfn)
  (svref imm3 slot-id.index slot-id)
  (getvheader imm0 temp1)
  (ldr temp0 'table nfn)
  (header-length imm5 imm0)
  (cmplr imm3 imm5)
  #+ppc64-target (srdi imm3 imm3 1)
  (la imm0 target::misc-data-offset imm3)
  (bge @missing)
  (lwzx imm1 temp1 imm0)
  (cmpwi imm1 0)
  (slri imm1 imm1 target::word-shift)
  (la imm1 target::misc-data-offset imm1)
  (beq @missing)
  @have-scaled-table-index
  (ldr temp1 'class nfn)
  (ldrx arg_y temp0 imm1)
  (ldr nfn '%maybe-std-setf-slot-value-using-class nfn)
  (set-nargs 4)
  (svref temp0 0 nfn)
  (vpush temp1)
  (mtctr temp0)
  (bctr)
  @missing                              ; (%slot-id-set-missing instance id new-value)
  (ldr nfn '%slot-id-ref-missing nfn)
  (set-nargs 3)
  (ldr temp0 target::misc-data-offset nfn)
  (mtctr temp0)
  (bctr))

#-dont-use-lexprs
(defparameter *gf-proto*
  (nfunction
   gag
   (lambda (&lap &lexpr args)
     (ppc-lap-function 
      gag 
      ()
      (mflr loc-pc)
      (vpush-argregs)
      (vpush nargs)
      (add imm0 vsp nargs)
      (la imm0 (ash 1 target::word-shift) imm0)                  ; caller's vsp
      (bla .SPlexpr-entry)
      (mtlr loc-pc)                     ; return to kernel
      (mr arg_z vsp)                    ; lexpr
      (svref arg_y gf.dispatch-table nfn) ; dispatch table
      (set-nargs 2)
      (svref nfn gf.dcode nfn)		; dcode function
      (ldr temp0 target::misc-data-offset nfn)
      (mtctr temp0)
      (bctr)))))

#+dont-use-lexprs
(defparameter *gf-proto*
  (nfunction
   gag
   (lambda (&lap &rest args)
     (ppc-lap-function
      gag
      ()
      ;;(bkpt)
      (mflr loc-pc)
      (bla .SPstack-rest-arg)
      (vpop arg_z)
      (stru sp (- target::lisp-frame.size) sp)
      (str fn target::lisp-frame.savefn sp)
      (str loc-pc target::lisp-frame.savelr sp)
      (str vsp target::lisp-frame.savevsp sp)
      (mr fn nfn)
      ;; If we were called for multiple values, call the dcode
      ;; for multiple values.
      (ref-global imm0 ret1valaddr)
      (cmpr imm0 loc-pc)
      (svref arg_y gf.dispatch-table fn) ; dispatch table
      (set-nargs 2)
      (svref nfn gf.dcode fn)		; dcode function
      (beq @multiple)
      (ldr temp0 target::misc-data-offset nfn)
      (mtctr temp0)
      (bctrl)
      (ldr tsp 0 tsp)
      (restore-full-lisp-context)
      (blr)
      @multiple
      (bl @getback)
      (mflr loc-pc)
      (stru sp (- target::lisp-frame.size) sp)
      (str fn target::lisp-frame.savefn sp)
      (str loc-pc target::lisp-frame.savelr sp)
      (str vsp target::lisp-frame.savevsp sp)
      (mtlr imm0)
      (li fn 0)
      (ldr temp0 target::misc-data-offset nfn)
      (mtctr temp0)
      (bctr)
      @getback
      (blrl)
      @back
      (ldr tsp 0 tsp)
      (ba .SPnvalret)))))
      
      

(defppclapfunction funcallable-trampoline ()
  (svref nfn gf.dcode nfn)
  (svref temp0 0 nfn)
  (mtctr temp0)
  (bctr))

;;; This can't reference any of the function's constants.
(defppclapfunction unset-fin-trampoline ()
  (mflr loc-pc)
  (bla .SPheap-rest-arg)                ; cons up an &rest arg, vpush it
  (vpop arg_z)                          ; whoops, didn't really want to
  (bla .SPsavecontextvsp)
  (li arg_x '#.$XNOFINFUNCTION)
  (mr arg_y nfn)
  (set-nargs 3)
  (bla .SPksignalerr)
  (li arg_z nil)
  (ba .SPpopj))

;;; is a winner - saves ~15%
(defppclapfunction gag-one-arg ((arg arg_z))
  (check-nargs 1)  
  (svref arg_y gf.dispatch-table nfn) ; mention dt first
  (set-nargs 2)
  (svref nfn gf.dcode nfn)
  (ldr temp0 target::misc-data-offset nfn)
  (mtctr temp0)
  (bctr))


(defppclapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z))
  (check-nargs 2)  
  (svref arg_x gf.dispatch-table nfn) ; mention dt first
  (set-nargs 3)
  (svref nfn gf.dcode nfn)
  (ldr temp0 target::misc-data-offset nfn)
  (mtctr temp0)
  (bctr))

(defparameter *cm-proto*
  (nfunction
   gag
   (lambda (&lap &lexpr args)
     (ppc-lap-function 
      gag 
      ()
      (mflr loc-pc)
      (vpush-argregs)
      (vpush nargs)
      (add imm0 vsp nargs)
      (la imm0 target::node-size imm0)                  ; caller's vsp
      (bla .SPlexpr-entry)
      (mtlr loc-pc)                     ; return to kernel
      (mr arg_z vsp)                    ; lexpr
      (svref arg_y combined-method.thing nfn) ; thing
      (set-nargs 2)
      (svref nfn combined-method.dcode nfn) ; dcode function
      (ldr temp0 target::misc-data-offset nfn)
      (mtctr temp0)
      (bctr)))))
