home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / m_dispatch.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.6 KB  |  321 lines
  1. (herald m68dispatch (env tsys))
  2.  
  3. (define (dispatch-init)
  4.   (lap (handle-stype handle-true handle-fixnum handle-pair
  5.         handle-char handle-nonvalue *handlers* icall-wrong-nargs
  6.         bogus-return bogus-return-miss apply handle-template handle-immediate
  7.     handle-magic-frame no-default-method)
  8.  
  9.     (move .l p (d@nil slink/dispatch))
  10.     (lea (label dispatch) a1)
  11.     (move .l a1 (d@nil slink/dispatch-label))
  12.     (move .l ($ -1) nargs)
  13.     (move .l (@r sp) tp)
  14.     (jmp (@r tp))))
  15.  
  16.  
  17. ; vframe obj op next self
  18.  
  19. (lap-template (0 0 -1 nil stack handle-dispatch-return)
  20. dispatch-return                  
  21.     (cmp .l AN nil-reg)                         ; did we get a method?
  22.     (j= default)                                ; AN contains code
  23.     (move .l  A1 P)                             ;  environment
  24.     (move .l (d@r P -2) TP)
  25.     (move .l (d@r SP 16) A1)                    ; self is first arg of method
  26. op-icall
  27.     (cmp .b (d@r AN template/nargs) NARGS)         ; check number of args
  28.     (j= %icall-ok)
  29.     (j< %icall-wrong-nargs)
  30.     (btst ($ 6) (d@r AN -2))                        ; check nary bit
  31.     (j= %icall-wrong-nargs)
  32. %icall-ok
  33.     (jmp (@r AN))
  34. %icall-wrong-nargs
  35.   (move .l a1 (d@r TASK task/t0))
  36.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  37.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  38.   (clr .l s0)
  39.   (jsr (*d@nil slink/nary-setup))
  40.   (move .l an a2)
  41.   (move .l (d@r SP 8) a1)   ; operation
  42.   (add .w ($ 20) SP)
  43.   (move .l (d@nil slink/dispatch) P)
  44.   (move .l (d@static P (static 'icall-wrong-nargs)) P)
  45.   (move .l (d@r P -2) TP)
  46.   (jmp  (@r TP))
  47. default
  48.     (move .l (d@r SP 16) A1)                         ; self is first arg of method
  49.     (move .l (d@r P offset/operation-default) P)
  50.     (cmp .l p nil-reg)
  51.     (j= no-default)
  52.     (add .w ($ 20) SP)
  53.     (jmp (*d@nil slink/icall))
  54. no-default    
  55.   (move .l a1 (d@r TASK task/t0))
  56.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  57.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  58.   (clr .l s0)
  59.   (jsr (*d@nil slink/nary-setup))
  60.   (move .l an a2)
  61.   (move .l (d@r SP 8) a1)   ; operation
  62.   (add .w ($ 20) SP)
  63.   (move .l (d@nil slink/dispatch) P)
  64.   (move .l (d@static P (static 'no-default-method)) P)
  65.   (move .l (d@r P -2) TP)
  66.   (jmp  (@r TP))
  67. handle-dispatch-return    
  68.     (move .l nil-reg AN)
  69.     (rts))
  70.                               
  71.                            
  72. (define *structure-template*
  73.   (lap-template (0 0 0 nil heap structure-handler)
  74.     (jmp (*d@nil slink/undefined-effect))
  75. structure-handler
  76.     (move .l (d@r A1 -2) A1)                       ; internal-template
  77.     (move .l (d@r A1 -30) A1)                        ; stype-handler
  78.     (jmp (label dispatch))))
  79.     
  80. (define *stype-template*
  81.   (lap-template (9 0 0 nil heap stype-handler)           ; stype size is 9
  82.     (jmp (*d@nil slink/undefined-effect))
  83. stype-handler
  84.   (move .l (d@nil slink/dispatch) AN)
  85.   (move .l (d@static AN (static 'handle-stype)) A1)
  86.   (jmp (label dispatch))))
  87.  
  88. (define *traced-op-template*
  89.   (lap-template (0 0 0 nil stack t-op)
  90.     (move .l A1 (@-r SP))                                       ; self
  91.     (move .l nil-reg (@-r SP))                                  ; next
  92.     (move .l P (@-r SP))                                        ; op
  93.     (move .l A1 (@-r SP))                                       ; obj
  94.     (move .l ($ (fx+ (fixnum-ashl 4 16) header/vframe)) (@-r sp))
  95.     (pea (label traced-op-return))
  96.     (jmp (label dispatch))
  97. t-op))
  98.     
  99. (lap-template (0 0 -1 nil stack handle-traced-op-return)
  100. traced-op-return                  
  101.     (cmp .l AN nil-reg)                         ; did we get a method?
  102.     (j= traced-op-default)                      ; AN contains code
  103.     (move .l A1 P)                              ; environment
  104.     (move .l (d@r P -2) TP)
  105.     (move .l (d@r SP 16) A1)                         ; self is first arg of method
  106.     (jbr op-icall)
  107. traced-op-default
  108.     (move .l (d@r P 6) P)                       ; rhs is operation
  109.     (jbr default)
  110. handle-traced-op-return    
  111.     (move .l nil-reg AN)
  112.     (rts))
  113.   
  114.  
  115. ;;; We have the operation in P, the object in A1 and we can use AN which is
  116. ;;; where the method id returned
  117.  
  118. (define *operation-template*
  119.   (lap-template (3 0 1 t heap operation-handler)
  120.     (move .l A1 (@-r SP))                                       ; self
  121.     (move .l nil-reg (@-r SP))                                  ; next
  122.     (move .l P (@-r SP))                                        ; op
  123.     (move .l A1 (@-r SP))                                       ; obj
  124.     (move .l ($ (fx+ (fixnum-ashl 4 16) header/vframe)) (@-r sp))
  125.     (pea (label dispatch-return))
  126. dispatch 
  127.     (move .l A1 S0)                                 ; is object extend?
  128.     (and .b ($ 3) S0)                              
  129.     (cmp .b ($ tag/extend) S0)
  130.     (jn= object-not-extend)                         ; if so
  131.     (move .l (d@r A1 -2) S0)                        ; get object's header
  132.     (j< template)                                   ; is high bit set?
  133.                                                     ; watch for interrupt here!!
  134.     (move .l (d@r A1 -2) TP)                        ; object's header again
  135.     (and .b ($ 3) S0)                               ; is header a template?
  136.     (cmp .b ($ tag/extend) S0)
  137.     (jn= object-not-closure)                        ; if so
  138.     (cmp .w ($ M68-JUMP-ABSOLUTE) (@r TP))          ; closure internal template?
  139.     (j= cit)
  140.     (move .w (d@r TP -8) S0)                        ; get signed handler offset
  141.     (ext .l S0)                                     ; is it 0
  142.     (j= no-handler)                                 ; if so, no handler
  143.     (jmp (index (@r TP) S0))                        ; jump to handler
  144. no-handler              
  145.     (move .l nil-reg AN)
  146.     (rts)
  147. cit
  148.     (move .l (d@r TP 2) AN)                         ; get auxilliary template
  149.     (move .w (d@r AN -8) S0)                        ; get handler offset
  150.     (ext .l S0)
  151.     (j= no-handler)
  152.     (jmp (index (@r AN) S0))                        ; jump to handler
  153. template
  154.     (move .l (d@nil slink/dispatch) AN)
  155.     (move .l (d@static AN (static 'handle-template)) A1)
  156.     (jmp (label dispatch))
  157. object-not-extend
  158.     (move .l (d@nil slink/dispatch) AN)
  159.     (cmp .b ($ tag/fixnum) S0)
  160.     (j= fixnum)
  161.     (cmp .b ($ tag/pair) S0)
  162.     (j= pair)
  163.     (move .l A1 S0)
  164.     (cmp .b ($ header/char) S0)
  165.     (j= char)
  166.     (cmp .b ($ header/true) S0)
  167.     (j= true)
  168.     (cmp .b ($ header/nonvalue) S0)
  169.     (j= nonvalue)
  170.     (move .l (d@static AN (static 'handle-immediate)) A1)
  171.     (jmp (label dispatch))
  172. true
  173.     (move .l (d@static AN (static 'handle-true)) A1)
  174.     (jmp (label dispatch))
  175. fixnum   
  176.     (move .l (d@static AN (static 'handle-fixnum)) A1)
  177.     (jmp (label dispatch))
  178. pair
  179.     (move .l (d@static AN (static 'handle-pair)) A1)
  180.     (jmp (label dispatch))
  181. char
  182.     (move .l (d@static AN (static 'handle-char)) A1)
  183.     (jmp (label dispatch))            
  184. nonvalue
  185.     (move .l (d@static AN (static 'handle-nonvalue)) A1)
  186.     (jmp (label dispatch))            
  187. object-not-closure
  188.     (move .l (d@nil slink/dispatch) AN)
  189.     (move .l (d@static AN (static '*handlers*)) AN)
  190.     (move .l TP S0)
  191.     (and .l ($ #x0000007C) S0)                 ;; isolate low seven bits
  192.     (move .l (index (d@r AN 2) S0) A1)
  193.     (jmp (label dispatch))
  194. operation-handler
  195.   (move .l (d@r A1 offset/operation-handler) A1)
  196.   (jmp (label dispatch))))
  197.  
  198. ;;; At the top of the join loop the stack looks like   self                   
  199. ;;;                                                    next
  200. ;;;                                                    op
  201. ;;;                                                    obj
  202. ;;;                                                    vframe-header
  203. ;;;                                              sp -> dispatch-return-template
  204.  
  205.  
  206. (define *join-template*
  207.   (lap-template (2 0 1 t heap join-handler)
  208. join-template
  209.     (move .l (d@r P 2) P)                     ; joined lhs
  210.     (jmp (*d@nil slink/icall))                       
  211. join-handler                                            
  212.     (move .l (d@r A1 6) (d@r SP 16))          ; next ,- rhs
  213.     (move .l (d@r A1 2) A1)                   ; get joined lhs
  214.     (move .l A1 (d@r SP 8))                   ; obj <- lhs
  215.     (pea (label join-return))
  216.     (jmp (label dispatch))))               ; try to get a handler from lhs
  217.  
  218. (lap-template (0 0 -1 t stack join-return-handler)
  219. join-return
  220.     (cmp .l AN nil-reg)                      ; did we get a handler?
  221.     (j= join-miss)
  222.     (rts)
  223. join-miss
  224.     (move .l (d@r SP 16) A1)
  225.     (move .l A1 (d@r SP 8))                  ; next becomes obj
  226.     (move .l (d@nil slink/dispatch) AN)
  227.     (move .l nil-reg (d@r SP 16))          ; next
  228.     (jmp (label dispatch))                 ; try rhs
  229. join-return-handler
  230.     (move .l nil-reg AN)
  231.     (rts))
  232.  
  233. (define *bogus-entity-template*
  234.   (lap-template (2 0 1 t heap bogus-entity-handler)
  235.     (move .l (d@r P 2) P)
  236.     (jmp (*d@nil slink/icall))
  237. bogus-entity-handler
  238.     (move .l NARGS S2)   
  239.     (move .l A2 (d@r TASK (+ task/T0 4)))
  240.     (move .l A3 (d@r TASK (+ task/T0 8)))
  241.     (move .l ($ 1) S0)
  242.     (jsr (*d@nil slink/nary-setup))
  243.     (move .l (d@r A1 6) A2)               ; bogus-entity handler
  244.     (move .l P A1)                        ; operation is argument to handler
  245.     (move .l A2 P)
  246.     (move .l S2 (@-r SP))   ; save nargs
  247.     (move .l AN (@-r SP))   ; save arglist    
  248.     (pea (label bogus-return))
  249.     (move .l ($ 2) NARGS)
  250.     (jmp (*d@nil slink/icall))))
  251.  
  252. (lap-template (2 0 -1 nil stack bogus-return-handler)
  253. bogus-return
  254.     (cmp .l A1 nil-reg)
  255.     (jn= bogus-return-hit)
  256.     (move .l (d@nil slink/dispatch) AN)
  257.     (move .l (d@r SP 4) A3)               ; args
  258.     (move .l A1 A2)                       ; method
  259.     (move .l (d@static AN (static 'bogus-return-miss)) A1)
  260.     (move .l (d@static AN (static 'apply)) P)
  261.     (add .w ($ 12) SP)    ; pop off bogus return continuation
  262.     (move .l ($ 4) NARGS)
  263.     (move .l (d@r P -2) TP)
  264.     (jmp (@r TP))
  265. bogus-return-hit
  266.     (move .l (d@nil slink/dispatch) AN)
  267.     (move .l (d@r SP 4) (d@r TASK (+ task/T0 12)))               ; args
  268.     (move .l A1 A2)                       ; method
  269.     (move .l (d@static AN (static 'bogus-return)) A1)
  270.     (move .l (d@static AN (static 'apply)) P)
  271.     (move .l ($ 5) NARGS)      ; dummy obj in a3
  272.     (move .l (d@r P -2) TP)
  273.     (jmp (@r TP))
  274. bogus-return-handler
  275.     (move .l nil-reg AN)
  276.     (rts))
  277.  
  278. (define (bogus-return-miss method  . args)
  279.   (lap ()
  280.     (move .l nil-reg AN)                  ; compiled handlers return register
  281.     (lea (label join-return) A1)
  282.     (cmp .l (@r SP) A1)
  283.     (j= joined-bogus-return-miss)
  284.     (move .l (d@r SP 12) P)                ; restore operation
  285.     (rts)
  286. joined-bogus-return-miss
  287.     (move .l (d@r SP 16) P)                ; restore operation
  288.     (add .w ($ 4) SP)                      ; pop return addr
  289.     (jbr join-miss)))
  290.  
  291.  
  292. (define (bogus-return method obj . args)
  293.   (lap ()
  294.     (move .l (d@r SP 8) NARGS)            ; restore nargs and pop continuation
  295.     (add .l ($ 1) NARGS)                  ; add one for obj
  296.     (add .w ($ 12) SP)
  297.     (move .l A1 P)                        ; method in procedure register
  298.     (lea (label join-return) A1)          ; is a join return address on top?
  299.     (cmp .l (@r SP) A1)
  300.     (jn= bogus-dispatch-return)
  301. joined-bogus-return
  302.     (add .w ($ 4) SP)                      ; pop join return addr
  303. bogus-dispatch-return
  304.     (move .l (d@r SP 20) A1)              ; self is first of interpreted method
  305.     (move .l (d@r SP 8)  A2)              ; obj is second of interpreted method
  306.     (add .w ($ 24) SP)                    ; dispatch return + vframe 
  307.     (jmp (*d@nil slink/icall))))
  308.  
  309.  
  310.  
  311. (define *magic-frame-template*
  312.  (lap-template (4 0 -1 t stack magic-frame-handler)
  313.   (lea (d@r SP 20) SP)
  314.   (move .l (@r sp) tp)
  315.   (jmp (@r tp))
  316. magic-frame-handler
  317.   (move .l (d@nil  slink/dispatch) AN)
  318.   (move .l (d@static AN (static 'handle-magic-frame)) A1)
  319.   (jmp (label dispatch))))
  320.  
  321. (dispatch-init)