;;;-*- 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.
(defarmlapfunction %small-map-slot-id-lookup ((slot-id arg_z))
  (ldr temp1 (:@ nfn 'map))
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (header-length imm1 imm0)
  (ldr temp0 (:@ nfn 'table))
  (cmp arg_x imm1)
  (mov imm0 (:lsr arg_x (:$ arm::word-shift)))
  (add imm0 imm0 (:$ arm::misc-data-offset))
  (mov imm1 (:$ arm::misc-data-offset))
  (ldrblo imm1 (:@ temp1 imm0))
  (movlo imm1 (:lsl imm1 (:$ arm::word-shift)))
  (addlo imm1 imm1 (:$ arm::misc-data-offset))
  (ldr arg_z (:@ temp0 imm1))
  (bx lr))

;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32).
(defarmlapfunction %large-map-slot-id-lookup ((slot-id arg_z))
  (ldr temp1 (:@ nfn 'map))
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (header-length imm1 imm0)
  (ldr temp0 (:@ nfn 'table))
  (cmp arg_x imm1)
  (add imm0 arg_x (:$ arm::misc-data-offset))
  (mov imm1 (:$ arm::misc-data-offset))
  (ldrlo imm1 (:@ temp1 imm0))
  (addlo imm1 imm1 (:$ arm::misc-data-offset))
  (ldr arg_z (:@ temp0 imm1))
  (bx lr))

(defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z))
  (ldr temp1 (:@ nfn 'map))
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (ldr temp0 (:@ nfn 'table))
  (header-length imm1 imm0)
  (cmp arg_x imm1)
  (mov imm0 (:lsr arg_x (:$ arm::word-shift)))
  (add imm0 imm0 (:$ arm::misc-data-offset))
  (bhs @missing)
  (ldrb imm1 (:@ temp1 imm0))
  (cmp imm1 (:$ 0))
  (mov imm1 (:lsl imm1 (:$ arm::word-shift)))
  (add imm1 imm1 (:$ arm::misc-data-offset))
  (beq @missing)
  (ldr arg_z (:@ temp0 imm1))
  (ldr arg_x (:@ nfn 'class))
  (ldr nfn (:@ nfn '%maybe-std-slot-value))
  (set-nargs 3)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
  @missing                              ; (%slot-id-ref-missing instance id)
  (ldr nfn (:@ nfn '%slot-id-ref-missing))
  (set-nargs 2)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))

(defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z))
  (ldr temp1 (:@ nfn 'map))
  (svref arg_x slot-id.index slot-id)
  (getvheader imm0 temp1)
  (ldr temp0 (:@ nfn 'table))
  (header-length imm1 imm0)
  (cmp arg_x imm1)
  (movhs arg_x (:$ 0))
  (add imm0 arg_x (:$ arm::misc-data-offset))
  (ldr imm1 (:@ temp1 imm0))
  (movs imm1 (:lsl imm1 (:$ arm::fixnumshift)))
  (add imm1 imm1 (:$ arm::misc-data-offset))
  @have-scaled-table-index
  (ldrne arg_x (:@ nfn 'class))
  (ldrne nfn (:@ nfn '%maybe-std-slot-value-using-class))
  (ldrne arg_z (:@ temp0 imm1))
  (set-nargs 3)
  (ldrne pc (:@ nfn (:$ arm::function.entrypoint)))
  @missing                              ; (%slot-id-ref-missing instance id)
  (ldr nfn (:@ nfn '%slot-id-ref-missing))
  (set-nargs 2)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))


(defarmlapfunction %small-set-slot-id-value ((instance arg_x)
                                             (slot-id arg_y)
                                             (new-value arg_z))
  (ldr temp1 (:@ nfn 'map))
  (svref temp0 slot-id.index slot-id)
  (getvheader imm0 temp1)
  (header-length imm1 imm0)
  (cmp temp0 imm1)
  (mov imm0 (:lsr temp0 (:$ arm::word-shift)))
  (ldr temp0 (:@ nfn 'table))
  (add imm0 imm0 (:$ arm::misc-data-offset))
  (bhs @missing)
  (ldrb imm1 (:@ temp1 imm0))
  (cmp imm1 (:$ 0))
  (mov imm1 (:lsl imm1 (:$ arm::word-shift)))
  (add imm1 imm1 (:$ arm::misc-data-offset))
  (beq @missing)
  @have-scaled-table-index
  (ldr temp1 (:@ nfn 'class))
  (ldr arg_y (:@ temp0 imm1))
  (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class))
  (set-nargs 4)
  (vpush1 temp1)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
  @missing                              ; (%slot-id-set-missing instance id new-value)
  (ldr nfn (:@ nfn '%slot-id-set-missing))
  (set-nargs 3)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))

(defarmlapfunction %large-set-slot-id-value ((instance arg_x)
                                             (slot-id arg_y)
                                             (new-value arg_z))
  (ldr temp1 (:@ nfn 'map))
  (svref temp0 slot-id.index slot-id)
  (getvheader imm0 temp1)
  (header-length imm1 imm0)
  (cmp temp0 imm1)
  (add imm0 temp0 (:$ arm::misc-data-offset))
  (ldr temp0 (:@ nfn 'table))
  (bhs @missing)
  (ldr imm1 (:@ temp1 imm0))
  (movs imm1 (:lsl imm1 (:$ arm::fixnumshift)))
  (add imm1 imm1 (:$ arm::misc-data-offset))
  (beq @missing)
  @have-scaled-table-index
  (ldr temp1 (:@ nfn 'class))
  (ldr arg_y (:@ temp0 imm1))
  (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class))
  (set-nargs 4)
  (vpush1 temp1)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
  @missing                              ; (%slot-id-set-missing instance id new-value)
  (ldr nfn (:@ nfn '%slot-id-ref-missing))
  (set-nargs 3)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
)

(defparameter *gf-proto*
  (nfunction
   gag
   (lambda (&lap &lexpr args)
     (arm-lap-function 
      gag 
      ()
      (vpush-argregs)
      (vpush1 nargs)
      (ref-global arg_x ret1valaddr)
      (add imm1 vsp nargs)
      (add imm1 imm1 (:$ arm::node-size))                  ; caller's vsp
      (cmp lr arg_x)
      (build-lisp-frame imm0 imm1)
      (mov fn (:$ 0))
      (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
      (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
      (stmdbeq (:! sp) (imm0 imm1 fn lr))
      (moveq lr arg_x)
      (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
      (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
      (mov arg_z vsp)
      (nth-immediate arg_y gf.dispatch-table nfn) ; dispatch-table
      (set-nargs 2)
      (nth-immediate nfn gf.dcode nfn) ; dcode function
      (ldr pc (:@ nfn (:$ arm::function.entrypoint)))))))


      
      

(defarmlapfunction funcallable-trampoline ()
  (nth-immediate nfn gf.dcode nfn)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))

;;; This can't reference any of the function's constants.
(defarmlapfunction unset-fin-trampoline ()
  (build-lisp-frame)
  (sploadlr .SPheap-rest-arg)                 ; cons up an &rest arg, vpush it
  (blx lr)
  (vpop1 arg_z)                          ; whoops, didn't really want to
  (mov arg_x '#.$XNOFINFUNCTION)
  (mov arg_y nfn)
  (set-nargs 3)
  (sploadlr .SPksignalerr)
  (blx lr)
  (mov arg_z 'nil)
  (return-lisp-frame))

;;; is a winner - saves ~15%
(defarmlapfunction gag-one-arg ((arg arg_z))
  (check-nargs 1)  
  (nth-immediate arg_y gf.dispatch-table nfn) ; mention dt first
  (set-nargs 2)
  (nth-immediate nfn gf.dcode nfn)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))


(defarmlapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z))
  (check-nargs 2)  
  (nth-immediate arg_x gf.dispatch-table nfn) ; mention dt first
  (set-nargs 3)
  (nth-immediate nfn gf.dcode nfn)
  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))

(defparameter *cm-proto*
  (nfunction
   gag
   (lambda (&lap &lexpr args)
     (arm-lap-function 
      gag 
      ()
      (vpush-argregs)
      (vpush1 nargs)
      (ref-global arg_x ret1valaddr)
      (add imm1 vsp nargs)
      (add imm1 imm1 (:$ arm::node-size))                  ; caller's vsp
      (cmp lr arg_x)
      (build-lisp-frame imm0 imm1)
      (mov fn (:$ 0))
      (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
      (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
      (stmdbeq (:! sp) (imm0 imm1 fn lr))
      (moveq lr arg_x)
      (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
      (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
      (mov arg_z vsp)
      (nth-immediate arg_y combined-method.thing nfn) ; thing
      (set-nargs 2)
      (nth-immediate nfn combined-method.dcode nfn) ; dcode function
      (ldr pc (:@ nfn (:$ arm::function.entrypoint)))))))
