Add shortcircuit_apply hooks.

diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm
index 01937b0a36909af8359ba39d294305502a149b09..402f7c1da9b3498e075daf2c399743bb848cf341 100644 (file)
--- a/v7/src/compiler/machines/spectrum/lapgen.scm
+++ b/v7/src/compiler/machines/spectrum/lapgen.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 4.36 1991/05/07 17:44:02 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 4.37 1992/02/07 05:58:34 jinx Exp $
 $MC68020-Header: /scheme/compiler/bobcat/RCS/lapgen.scm,v 4.41 1991/05/06 23:05:51 jinx Exp $
 
-Copyright (c) 1988-1991 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -576,7 +576,16 @@ MIT in each case. |#
     -1+
     zero?
     positive?
-    negative?))
+    negative?
+    shortcircuit-apply
+    shortcircuit-apply-1
+    shortcircuit-apply-2
+    shortcircuit-apply-3
+    shortcircuit-apply-4
+    shortcircuit-apply-5
+    shortcircuit-apply-6
+    shortcircuit-apply-7
+    shortcircuit-apply-8))
 
 (define (invoke-hook hook)
   (LAP (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))

diff --git a/v7/src/compiler/machines/spectrum/rules3.scm b/v7/src/compiler/machines/spectrum/rules3.scm
index 955c9ab7b713ed764f0b9c9d4d74e9459ab0d624..568a6714fbd191292f1232a829995e85e7b13844 100644 (file)
--- a/v7/src/compiler/machines/spectrum/rules3.scm
+++ b/v7/src/compiler/machines/spectrum/rules3.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules3.scm,v 4.30 1991/05/07 17:54:14 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules3.scm,v 4.31 1992/02/07 05:58:22 jinx Exp $
 $MC68020-Header: /scheme/compiler/bobcat/RCS/rules3.scm,v 4.30 1991/05/07 13:45:31 jinx Exp $
 
-Copyright (c) 1988-1991 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -60,9 +60,28 @@ MIT in each case. |#
   (INVOCATION:APPLY (? frame-size) (? continuation))
   continuation                         ;ignore
   (LAP ,@(clear-map!)
-       ,@(load-immediate frame-size regnum:second-arg)
-       (LDWM () (OFFSET 4 0 22) ,regnum:first-arg) ; procedure
-       ,@(invoke-interface code:compiler-apply)))
+       ,@(case frame-size
+          ((1) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-1 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((2) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-2 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((3) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-3 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((4) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-4 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((5) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-5 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((6) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-6 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((7) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-7 4
+                                    ,regnum:scheme-to-interface-ble))))
+          ((8) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-8 4
+                                    ,regnum:scheme-to-interface-ble))))
+          (else
+           (LAP ,@(load-immediate frame-size regnum:second-arg)
+                (BLE () (OFFSET ,hook:compiler-shortcircuit-apply 4
+                                ,regnum:scheme-to-interface-ble)))))
+       (LDWM () (OFFSET 4 0 22) ,regnum:first-arg)))
 
 (define-rule statement
   (INVOCATION:JUMP (? frame-size) (? continuation) (? label))

diff --git a/v7/src/microcode/cmpauxmd/hppa.m4 b/v7/src/microcode/cmpauxmd/hppa.m4
index c7e2d513c4387b3b6ca39b371aaaacec624c447b..45ae85fb2fc96dcd510db3d5fb103d8540675f12 100644 (file)
--- a/v7/src/microcode/cmpauxmd/hppa.m4
+++ b/v7/src/microcode/cmpauxmd/hppa.m4
@@ -1,8 +1,8 @@
 changecom(`;');;; -*-Midas-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/hppa.m4,v 1.19 1992/02/05 01:44:36 jinx Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/hppa.m4,v 1.20 1992/02/07 05:58:12 jinx Exp $
 ;;;
-;;;    Copyright (c) 1989-91 Massachusetts Institute of Technology
+;;;    Copyright (c) 1989-1992 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -298,30 +298,47 @@ generic_positive_hook
 generic_negative_hook
        B       generic_negative+4
        LDW     0(0,22),6               ; arg1
-\f
-no_hook
+
+shortcircuit_apply_hook
+       B       shortcircuit_apply+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_1_hook
+       B       shortcircuit_apply_1+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_2_hook
+       B       shortcircuit_apply_2+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_3_hook
+       B       shortcircuit_apply_3+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+\f      
+shortcircuit_apply_4_hook
+       B       shortcircuit_apply_4+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_5_hook
+       B       shortcircuit_apply_5+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_6_hook
+       B       shortcircuit_apply_6+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_7_hook
+       B       shortcircuit_apply_7+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_8_hook
+       B       shortcircuit_apply_8+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
 ;;
-;; Provide dummy trapping hooks in case a newver version of compiled
+;; Provide dummy trapping hooks in case a newer version of compiled
 ;; code that expects more hooks is run.
 ;;
-       BREAK   0,18
-       NOP
-       BREAK   0,19
-       NOP
-       BREAK   0,20
-       NOP
-       BREAK   0,21
-       NOP
-       BREAK   0,22
-       NOP
-       BREAK   0,23
-       NOP
-       BREAK   0,24
-       NOP
-       BREAK   0,25
-       NOP
-       BREAK   0,26
-       NOP
+no_hook
        BREAK   0,27
        NOP
        BREAK   0,28
@@ -350,6 +367,26 @@ no_hook
        NOP
        BREAK   0,39
        NOP
+       BREAK   0,40
+       NOP
+       BREAK   0,41
+       NOP
+       BREAK   0,42
+       NOP
+       BREAK   0,43
+       NOP
+       BREAK   0,44
+       NOP
+       BREAK   0,45
+       NOP
+       BREAK   0,46
+       NOP
+       BREAK   0,47
+       NOP
+       BREAK   0,48
+       NOP
+       BREAK   0,49
+       NOP
 
 ifelse(ASM_DEBUG,1,"interface_break
        COMB,=  21,22,interface_break
@@ -709,6 +746,43 @@ define_generic_binary(plus,2b,FADD)
 define_generic_unary_predicate(positive,2c,>)
 define_generic_unary_predicate(zero,2d,=)
 \f
+;;;; Optimized procedure application for unknown procedures.
+;;;  Procedure in r26, arity (for shortcircuit-apply) in r25.
+
+shortcircuit_apply
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       COMICLR,=       TC_CCENTRY,24,0
+       B,N     shortcircuit_apply_lose
+       DEP     5,5,6,26                ; procedure -> address
+       LDB     -3(0,26),23             ; procedure's frame-size
+       COMB,<>,N       25,23,shortcircuit_apply_lose
+       BLE,N   0(5,26)                 ; invoke procedure
+
+define(define_shortcircuit_fixed,
+"shortcircuit_apply_$1
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       COMICLR,=       TC_CCENTRY,24,0
+       B       shortcircuit_apply_lose
+       LDI     $1,25
+       DEP     5,5,6,26                ; procedure -> address
+       LDB     -3(0,26),23             ; procedure's frame-size
+       COMB,<>,N       25,23,shortcircuit_apply_lose
+       BLE,N   0(5,26)                 ; invoke procedure")
+
+define_shortcircuit_fixed(1)
+define_shortcircuit_fixed(2)
+define_shortcircuit_fixed(3)
+define_shortcircuit_fixed(4)
+define_shortcircuit_fixed(5)
+define_shortcircuit_fixed(6)
+define_shortcircuit_fixed(7)
+define_shortcircuit_fixed(8)
+
+shortcircuit_apply_lose
+       DEP     24,5,6,26               ; insert type back
+       B       scheme_to_interface
+       LDI     0x14,28
+\f
 ;;;; Assembly language entry point used by utilities in cmpint.c
 ;;;  to return to the interpreter.
 ;;;  It returns from C_to_interface.

diff --git a/v8/src/microcode/cmpauxmd/hppa.m4 b/v8/src/microcode/cmpauxmd/hppa.m4
index 18f23eeba28087fbe3eca4f2710ce12ac5ec365a..d82c969962155794870074ed505260f6a61d62d2 100644 (file)
--- a/v8/src/microcode/cmpauxmd/hppa.m4
+++ b/v8/src/microcode/cmpauxmd/hppa.m4
@@ -1,8 +1,8 @@
 changecom(`;');;; -*-Midas-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpauxmd/hppa.m4,v 1.19 1992/02/05 01:44:36 jinx Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpauxmd/hppa.m4,v 1.20 1992/02/07 05:58:12 jinx Exp $
 ;;;
-;;;    Copyright (c) 1989-91 Massachusetts Institute of Technology
+;;;    Copyright (c) 1989-1992 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -298,30 +298,47 @@ generic_positive_hook
 generic_negative_hook
        B       generic_negative+4
        LDW     0(0,22),6               ; arg1
-\f
-no_hook
+
+shortcircuit_apply_hook
+       B       shortcircuit_apply+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_1_hook
+       B       shortcircuit_apply_1+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_2_hook
+       B       shortcircuit_apply_2+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_3_hook
+       B       shortcircuit_apply_3+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+\f      
+shortcircuit_apply_4_hook
+       B       shortcircuit_apply_4+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_5_hook
+       B       shortcircuit_apply_5+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_6_hook
+       B       shortcircuit_apply_6+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_7_hook
+       B       shortcircuit_apply_7+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       
+shortcircuit_apply_8_hook
+       B       shortcircuit_apply_8+4
+       EXTRU   26,5,6,24               ; procedure type -> 24
 ;;
-;; Provide dummy trapping hooks in case a newver version of compiled
+;; Provide dummy trapping hooks in case a newer version of compiled
 ;; code that expects more hooks is run.
 ;;
-       BREAK   0,18
-       NOP
-       BREAK   0,19
-       NOP
-       BREAK   0,20
-       NOP
-       BREAK   0,21
-       NOP
-       BREAK   0,22
-       NOP
-       BREAK   0,23
-       NOP
-       BREAK   0,24
-       NOP
-       BREAK   0,25
-       NOP
-       BREAK   0,26
-       NOP
+no_hook
        BREAK   0,27
        NOP
        BREAK   0,28
@@ -350,6 +367,26 @@ no_hook
        NOP
        BREAK   0,39
        NOP
+       BREAK   0,40
+       NOP
+       BREAK   0,41
+       NOP
+       BREAK   0,42
+       NOP
+       BREAK   0,43
+       NOP
+       BREAK   0,44
+       NOP
+       BREAK   0,45
+       NOP
+       BREAK   0,46
+       NOP
+       BREAK   0,47
+       NOP
+       BREAK   0,48
+       NOP
+       BREAK   0,49
+       NOP
 
 ifelse(ASM_DEBUG,1,"interface_break
        COMB,=  21,22,interface_break
@@ -709,6 +746,43 @@ define_generic_binary(plus,2b,FADD)
 define_generic_unary_predicate(positive,2c,>)
 define_generic_unary_predicate(zero,2d,=)
 \f
+;;;; Optimized procedure application for unknown procedures.
+;;;  Procedure in r26, arity (for shortcircuit-apply) in r25.
+
+shortcircuit_apply
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       COMICLR,=       TC_CCENTRY,24,0
+       B,N     shortcircuit_apply_lose
+       DEP     5,5,6,26                ; procedure -> address
+       LDB     -3(0,26),23             ; procedure's frame-size
+       COMB,<>,N       25,23,shortcircuit_apply_lose
+       BLE,N   0(5,26)                 ; invoke procedure
+
+define(define_shortcircuit_fixed,
+"shortcircuit_apply_$1
+       EXTRU   26,5,6,24               ; procedure type -> 24
+       COMICLR,=       TC_CCENTRY,24,0
+       B       shortcircuit_apply_lose
+       LDI     $1,25
+       DEP     5,5,6,26                ; procedure -> address
+       LDB     -3(0,26),23             ; procedure's frame-size
+       COMB,<>,N       25,23,shortcircuit_apply_lose
+       BLE,N   0(5,26)                 ; invoke procedure")
+
+define_shortcircuit_fixed(1)
+define_shortcircuit_fixed(2)
+define_shortcircuit_fixed(3)
+define_shortcircuit_fixed(4)
+define_shortcircuit_fixed(5)
+define_shortcircuit_fixed(6)
+define_shortcircuit_fixed(7)
+define_shortcircuit_fixed(8)
+
+shortcircuit_apply_lose
+       DEP     24,5,6,26               ; insert type back
+       B       scheme_to_interface
+       LDI     0x14,28
+\f
 ;;;; Assembly language entry point used by utilities in cmpint.c
 ;;;  to return to the interpreter.
 ;;;  It returns from C_to_interface.