mim/development/mim/vaxc/callrte.mud

   1 <USE "CHANNEL-TYPE">
   2
   3 <DEFINE FIND-CALL (ATM LIST)
   4   #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM]>)
   5   <REPEAT ()
   6     <COND (<EMPTY? .LIST> <RETURN <>>)>
   7     <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN T>)>
   8     <SET LIST <REST .LIST>>>>
   9
  10 <DEFINE SAME-NAME? (X Y "AUX" S1 S2)
  11   #DECL ((X Y) ATOM (S1 S2) STRING)
  12   <COND (<NOT ,INT-MODE>
  13          <==? .X .Y>)
  14         (T
  15          <SET S1 <SPNAME .X>>
  16          <SET S2 <SPNAME .Y>>
  17          <OR <==? .X .Y>
  18              <AND <G? <LENGTH .S1> 2>
  19                   <==? <1 .S1> !\T>
  20                   <==? <2 .S1> !\$>
  21                   <=? <REST .S1 2> .S2>>
  22              <AND <G? <LENGTH .S2> 2>
  23                   <==? <1 .S2> !\T>
  24                   <==? <2 .S2> !\$>
  25                   <=? <REST .S2 2> .S1>>>)>>
  26
  27 <DEFINE INIT-CALL-DISPATCH ()
  28         <SETG RTE-DISP-TABLE <IVECTOR ,RTE-DISPATCH-TABLE-SIZE <>>>
  29         <SETG RTE-PTR ,DISPATCH-TABLE-START>>
  30
  31 <GDECL (RTE-PTR) FIX>
  32
  33 <DEFINE CREATE-CALL-DESC (NAME FLUSH? RESULT?
  34                           "TUPLE" ARGS
  35                           "AUX" ANAME (OFF ,RTE-PTR))
  36         #DECL ((NAME) STRING (OFF) FIX (FLUSH?) BOOLEAN
  37                (RESULT?) <OR FALSE DATUM>)
  38         <SET ANAME
  39              <OR <LOOKUP .NAME ,MIMOP-OBLIST> <INSERT .NAME ,MIMOP-OBLIST>>>
  40         <PUT ,RTE-DISP-TABLE <+ </ .OFF 4> 1> .ANAME>
  41         <SETG .ANAME
  42               <CHTYPE <VECTOR .OFF .ANAME <VECTOR !.ARGS> .RESULT? .FLUSH?>
  43                       CALL-DESCRIPTOR>>
  44         <SETG RTE-PTR <+ ,RTE-PTR 4>>>
  45
  46 <DEFINE CREATE-DATUM (TYP TAC VAC)
  47         #DECL ((TYP TAC VAC) <OR FALSE ATOM>)
  48         <CHTYPE <VECTOR .TYP .TAC .VAC> DATUM>>
  49
  50 <DEFINE RTE-ARGS (KIND TAC VAC)
  51         #DECL ((KIND VAC) ATOM (TAC) <OR FALSE ATOM>)
  52         <COND (<NOT <MEMQ .KIND '[VALUE TYPE-VALUE-PAIR COUNT-VALUE-PAIR]>>
  53                <ERROR "BAD-AC-LDESC" CREATE-AC-LDESC>)>
  54         <COND (<AND .TAC <OR <NOT <GASSIGNED? .TAC>> <NOT <TYPE? ,.TAC AC>>>>
  55                <ERROR "BAD AC" CREATE-AC-LDESC>)>
  56         <COND (<OR <NOT <GASSIGNED? .VAC>> <NOT <TYPE? ,.VAC AC>>>
  57                <ERROR "BAD AC" CREATE-AC-LDESC>)>
  58         <CHTYPE <VECTOR .KIND .TAC .VAC> AC-LDESC>>
  59
  60 <SETG SAME-STACK <>>
  61
  62 <DEFINE CALL-RTE (CDESC INST DEST HINT "TUPLE" ARGS "AUX" JAC JADDR)
  63         #DECL ((CDESC) CALL-DESCRIPTOR (INST) ATOM
  64                (DEST) <OR ATOM FALSE VARTBL> (HINT) <OR FALSE HINT ATOM>)
  65         <COND (<AND <TYPE? .DEST VARTBL>
  66                     <NOT <MEMQ .DEST .ARGS>>
  67                     <OR <VAR-VALUE-IN-AC? .DEST>
  68                         <VAR-TYPE-IN-AC? .DEST>
  69                         <VAR-COUNT-IN-AC? .DEST>
  70                         <VAR-TYPE-WORD-IN-AC? .DEST>>>
  71                <DEAD-VAR .DEST>)>
  72         <MAPR <>
  73               <FUNCTION (SARGS ADS)
  74                       <PROCESS-RTE-ARG <1 .SARGS>
  75                                        <1 .ADS>
  76                                        .SARGS
  77                                        .ARGS
  78                                        <CD-ARGS .CDESC>>>
  79               .ARGS
  80               <CD-ARGS .CDESC>>
  81         <FREE-RESULT-ACS <CD-ARGS .CDESC> <CD-RESULT .CDESC>>
  82         <COND (<CD-FLUSH?-ACS .CDESC> <FLUSH-ALL-ACS>)>
  83         <SET JADDR <CD-DISP-OFFSET .CDESC>>
  84         <COND (<==? .INST CALL> <EMIT ,INST-JSB <MA-ABS .JADDR>>)
  85               (<==? .INST JUMP> <EMIT ,INST-JMP <MA-ABS .JADDR>>)>
  86         <SET-RTE-RESULT <CD-RESULT .CDESC> .DEST .HINT>
  87         <CLEAR-STATUS>
  88         NORMAL>
  89
  90 <DEFINE FREE-RESULT-ACS (ARGS RESULT "AUX" VAC)
  91         #DECL ((ARGS) <VECTOR [REST ARG-DESCRIPTOR]> (RESULT) <OR FALSE
  92                                                                   DATUM>)
  93         <COND (<TYPE? .RESULT DATUM>
  94                <COND (<SET VAC <DATUM-TAC .RESULT>>
  95                       <OR <CALLUSE? .VAC .ARGS> <GET-AC ,.VAC T>>)>
  96                <COND (<SET VAC <DATUM-VAC .RESULT>>
  97                       <OR <CALLUSE? .VAC .ARGS> <GET-AC ,.VAC T>>)>)>
  98         T>
  99
 100 <DEFINE CALLUSE? (VAC ARGS "AUX" (RES <>))
 101         #DECL ((VAC) ATOM (ARGS) <VECTOR [REST ARG-DESCRIPTOR]>)
 102         <MAPF <>
 103               <FCN (ARG)
 104                    <COND (<AND <TYPE? .ARG AC-LDESC>
 105                                <OR <==? <AC-LDESC-TAC .ARG> .VAC>
 106                                    <==? <AC-LDESC-VAC .ARG> .VAC>>>
 107                           <SET RES T>
 108                           <MAPLEAVE>)>>
 109               .ARGS>
 110         .RES>
 111
 112 <DEFINE SET-RTE-RESULT (RDAT DEST HINT)
 113         #DECL ((DEST) <OR FALSE ATOM VARTBL> (RDAT) <OR FALSE DATUM>
 114                (HINT) <OR FALSE HINT ATOM>)
 115         <COND (<AND .RDAT .DEST>
 116                <COND (<DATUM-TAC .RDAT>
 117                       <DEST-PAIR ,<DATUM-VAC .RDAT> ,<DATUM-TAC .RDAT> .DEST>)
 118                      (<DATUM-TYPE .RDAT>
 119                       <DEST-DECL ,<DATUM-VAC .RDAT> .DEST <DATUM-TYPE .RDAT>>)
 120                      (<ERROR "BAD DATUM" SET-RTE-RESULT>)>
 121                <PROCESS-DESTINATION-HINT .HINT .DEST>)>>
 122
 123 <NEWTYPE ARG-DONE FIX>
 124
 125 <DEFINE PROCESS-RTE-ARG PRA (ARG AD SARGS ARGS ADS "AUX" VAC TAC)
 126    #DECL ((ARGS) TUPLE (ADS) VECTOR (ARG) ANY (AD) <OR AC-LDESC ATOM>)
 127    <COND
 128     (<NOT <TYPE? .ARG ARG-DONE>>
 129      <COND (<==? .AD STACK>
 130             <COND (<TYPE? .ARG VARTBL> <PUSH-VAR .ARG>)
 131                   (ELSE <PUSH-CONSTANT .ARG>)>)
 132            (<AND <TYPE? .AD AC-LDESC>
 133                  <==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
 134                  <==? <NEXT-AC <SET TAC ,<AC-LDESC-TAC .AD>>>
 135                       <SET VAC ,<AC-LDESC-VAC .AD>>>>
 136             <CHECK-AC-USE .ARGS .SARGS .ADS .ARG .TAC .VAC>
 137             <COND (<TYPE? <SET ARG <1 .SARGS>> ARG-DONE> <RETURN T .PRA>)>
 138             <LOAD-AC-PAIR .ARG <> ,<AC-LDESC-TAC .AD>>
 139             <PROTECT-USE .TAC>
 140             <PROTECT-USE .VAC>)
 141            (<TYPE? .AD AC-LDESC>
 142             <CHECK-AC-USE .ARGS
 143                           .SARGS
 144                           .ADS
 145                           .ARG
 146                           <AC-LDESC-TAC .AD>
 147                           <AC-LDESC-VAC .AD>>
 148             <COND (<TYPE? <SET ARG <1 .SARGS>> ARG-DONE> <RETURN T .PRA>)>
 149             <COND (<TYPE? .ARG VARTBL>
 150                    <SET VAC
 151                         <LOAD-VAR .ARG
 152                                   <COND (<==? <AC-LDESC-KIND .AD>
 153                                               TYPE-VALUE-PAIR>
 154                                          VALUE)
 155                                         (ELSE JUST-VALUE)>
 156                                   T
 157                                   ,<AC-LDESC-VAC .AD>>>
 158                    <PROTECT-USE .VAC>)
 159                   (ELSE
 160                    <SET VAC <GET-AC ,<AC-LDESC-VAC .AD> T>>
 161                    <PROTECT-USE .VAC>
 162                    <MOVE-VALUE .ARG .VAC>
 163                    <MUNG-AC .VAC>)>
 164             <COND (<TYPE? .ARG VARTBL>
 165                    <COND (<==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
 166                           <SET VAC
 167                                <LOAD-VAR .ARG TYPE-WORD T ,<AC-LDESC-TAC
 168                                                             .AD>>>
 169                           <PROTECT-USE .VAC>)
 170                          (<==? <AC-LDESC-KIND .AD> COUNT-VALUE-PAIR>
 171                           <SET VAC <LOAD-VAR .ARG COUNT T ,<AC-LDESC-TAC
 172                                                             .AD>>>
 173                           <PROTECT-USE .VAC>)>)
 174                   (ELSE
 175                    <COND (<==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
 176                           <SET VAC <GET-AC ,<AC-LDESC-TAC .AD> T>>
 177                           <PROTECT-USE .VAC>
 178                           <MOVE-TYPE .ARG <MA-REG .VAC>>
 179                           <MUNG-AC .VAC>)
 180                          (<==? <AC-LDESC-KIND .AD> COUNT-VALUE-PAIR>
 181                           <SET VAC <GET-AC ,<AC-LDESC-TAC .AD> T>>
 182                           <PROTECT-USE .VAC>
 183                           <LOAD-CONSTANT .VAC <LENGTH .ARG>>
 184                           <MUNG-AC .VAC>)>)>)>
 185      <1 .SARGS <CHTYPE 0 ARG-DONE>>)>>
 186
 187 <DEFINE CHECK-AC-USE (ARGS SARGS ADS ARG
 188                       "TUPLE" ACS)
 189    #DECL ((SARGS ARGS) TUPLE (ADS) VECTOR (ACS) TUPLE)
 190    <MAPF <>
 191     <FUNCTION (AC)
 192        #DECL ((AC) <OR FALSE AC ATOM>)
 193        <COND (<TYPE? .AC ATOM> <SET AC ,.AC>)>
 194        <COND
 195         (.AC
 196          <MAPF <>
 197           <FUNCTION (LINKVAR "AUX" TV (VAR <LINKVAR-VAR .LINKVAR>))
 198              <COND
 199               (<OR <AND <==? .AC <LINKVAR-VALUE-AC .LINKVAR>>
 200                         <NOT <LINKVAR-VALUE-STORED .LINKVAR>>>
 201                    <AND <==? .AC <LINKVAR-TYPE-AC .LINKVAR>>
 202                         <NOT <LINKVAR-TYPE-STORED .LINKVAR>>>
 203                    <AND <==? .AC <LINKVAR-COUNT-AC .LINKVAR>>
 204                         <NOT <LINKVAR-COUNT-STORED .LINKVAR>>>
 205                    <AND <==? .AC <LINKVAR-TYPE-WORD-AC .LINKVAR>>
 206                         <NOT <LINKVAR-TYPE-STORED .LINKVAR>>>>
 207                                                   ;"Might be something in here"
 208                <REPEAT ((TV .ARGS))
 209                  <COND
 210                   (<SET TV <MEMQ .VAR .TV>>
 211                                        ;"It's OK if current arg is in right AC"
 212                    <COND
 213                     (<==? .TV .SARGS>
 214                      <SET TV <REST .TV>>)
 215                     (<L? <LENGTH .TV> <LENGTH .SARGS>>
 216                      <PROCESS-RTE-ARG
 217                       <1 .TV>
 218                       <NTH .ADS <+ 1 <- <LENGTH .ADS> <LENGTH .TV>>>>
 219                       .TV
 220                       .ARGS
 221                       .ADS>)
 222                     (T                                         ;"Loop detected"
 223                      <ISTORE-VAR .LINKVAR <> T>
 224                      ; "Can't use will-die? here"
 225                      <RETURN>)>)
 226                   (<RETURN>)>>)>>
 227           <AC-VARS .AC>>)>>
 228     .ACS>>
 229
 230 <DEFINE RESET-FRAME-LABEL-TABLE () <SETG FRAME-LABEL-TABLE ()>>
 231
 232 <DEFINE SFRAME-GEN ("OPTIONAL" (NAME <>))
 233         <FRAME-GEN .NAME T>>
 234
 235 <DEFINE FRAME-GEN ("OPTIONAL" (NAME <>) (SEG <>) "AUX" TLAB ELAB VAC)
 236         #DECL ((NAME) <OR FALSE ATOM>)
 237         <COND (<AND ,GLUE .NAME <QUICK-CALL? .NAME>>
 238                <EMIT-PUSH <TYPE-CODE <COND (.SEG QSFRAME)
 239                                            (ELSE QFRAME)>> WORD>
 240                <SET TLAB <MAKE-LABEL>>
 241                <SETG FRAME-LABEL-TABLE (.TLAB !,FRAME-LABEL-TABLE)>
 242                <EMIT-PUSH-LABEL .TLAB>
 243                <EMIT-PUSH <MA-REG ,AC-F> LONG>
 244                <SET ELAB <MAKE-LABEL>>
 245                <COND (<AND ,MAKTUP-FLAG <0? ,ICALL-LEVEL>>
 246                       <SET VAC <GET-AC PREF-VAL T>>
 247                       <EMIT-MOVE <MA-BD ,AC-F -4> <MA-REG .VAC> LONG>
 248                       <EMIT ,INST-TSTB <MA-BD .VAC -1>>
 249                       <GEN-BRANCH ,INST-BLSS .ELAB <>>
 250                       <EMIT-MOVE <MA-BD .VAC -4> <MA-REG .VAC> LONG>
 251                       <EMIT-LABEL .ELAB <>>
 252                       <EMIT-PUSH <MA-REG .VAC> LONG>)
 253                      (ELSE
 254                       <EMIT-PUSH <MA-BD ,AC-F -4> LONG>
 255                       <GEN-BRANCH ,INST-BGEQ .ELAB <>>
 256                       <EMIT-MOVE <MA-REG ,AC-F> <MA-BD ,AC-TP -4> LONG>
 257                       <EMIT-LABEL .ELAB <>>)>)
 258               (<CALL-RTE <COND (.SEG ,ISFRAME!-MIMOP)
 259                                (ELSE ,IFRAME!-MIMOP)> CALL <> <>>)>
 260         NORMAL>
 261
 262 <DEFINE SCALL-GEN (NAME NARGS RES DIR TAG COUNT "OPTIONAL" (HINT <>))
 263         <CCALL-GEN .NAME .NARGS .RES .TAG .COUNT .HINT>>
 264
 265 <DEFINE CALL-GEN (NAME NARGS "OPTIONAL" (RES <>) (HINT <>))
 266         <CCALL-GEN .NAME .NARGS .RES <> <> .HINT>>
 267
 268 <DEFINE CCALL-GEN (NAME NARGS RES TAG COUNT HINT "AUX" (TLAB <MAKE-LABEL>))
 269         #DECL ((NAME) <OR ATOM VARTBL> (NARGS) <OR FIX VARTBL>
 270                (RES) <OR ATOM VARTBL FALSE> (HINT) <OR FALSE ATOM>)
 271         <COND (<AND ,GLUE <TYPE? .NAME ATOM> <QUICK-CALL? .NAME>>
 272                <COND (<TYPE? .NARGS FIX>
 273                       <FLUSH-ALL-ACS>
 274                       <EMIT ,INST-MOVAL
 275                             <MA-DISP ,AC-TP <* -8 .NARGS>>
 276                             <MA-REG ,AC-F>>
 277                       <LOAD-CONSTANT ,AC-0 .NARGS>
 278                       <EMIT-CALL .NAME .NARGS>)
 279                      (ELSE
 280                       <LOAD-VAR .NARGS VALUE T ,AC-0>
 281                       <MAPF <>
 282                         <FUNCTION (X) <COND (<N==? .X ,AC-0>
 283                                              <MUNG-AC .X>)>>
 284                         ,ALL-ACS>
 285                       <EMIT ,INST-ASHL
 286                             <MA-IMM 3>
 287                             <MA-REG ,AC-0>
 288                             <MA-REG ,AC-1>>
 289                       <EMIT ,INST-SUBL3
 290                             <MA-REG ,AC-1>
 291                             <MA-REG ,AC-TP>
 292                             <MA-REG ,AC-F>>
 293                       <EMIT-CALL .NAME -1>)>
 294                <EMIT-LABEL <1 ,FRAME-LABEL-TABLE> <>>
 295                <SETG FRAME-LABEL-TABLE <REST ,FRAME-LABEL-TABLE>>
 296                <COND (.TAG
 297                       <EMIT-BRANCH ,INST-BRB .TLAB <> 0 <> T>
 298                       <EMIT ,INST-ADDL2 <MA-REG ,AC-1> <ADDR-VAR-VALUE .COUNT>>
 299                       <GEN-BRANCH ,INST-BRB .TAG <>>)>
 300                <EMIT-LABEL .TLAB <>>
 301                <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES .HINT>)
 302               (<CALL-RTE ,MCALL!-MIMOP
 303                          CALL
 304                          <COND (.TAG <>) (ELSE .RES)>
 305                          .HINT
 306                          .NARGS
 307                          .NAME>
 308                <COND (.TAG
 309                       <EMIT-BRANCH ,INST-BRB .TLAB <> 0 <> T>
 310                       <EMIT ,INST-ADDL2 <MA-REG ,AC-1> <ADDR-VAR-VALUE .COUNT>>
 311                       <GEN-BRANCH ,INST-BRB .TAG UNCONDITIONAL-BRANCH>
 312                       <EMIT-LABEL .TLAB <>>
 313                       <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES .HINT>)>)>
 314         NORMAL>
 315
 316 <DEFINE CALL-STACK-FUNCTION (ARGS CALLR TYP "TUPLE" CARGS "AUX" DEST (CNT 0))
 317         #DECL ((ARGS) TUPLE (CALLR) CALL-DESCRIPTOR (TYP) <OR ATOM FALSE>)
 318         <MAPR <>
 319               <FCN (FARGS "AUX" (ARG <1 .FARGS>))
 320                    <COND (<OR <==? .ARG STACK> <TYPE? .ARG VARTBL>>
 321                           <SET DEST .ARG>)>
 322                    <COND (<OR <1? <LENGTH .FARGS>> <TYPE? <2 .FARGS> LIST>>
 323                           <MAPLEAVE>)
 324                          (ELSE <PUSH-GEN .ARG> <SET CNT <+ .CNT 1>>)>>
 325               .ARGS>
 326         <CALL-RTE .CALLR CALL .DEST .TYP !.CARGS .CNT>
 327         NORMAL>
 328
 329 <DEFINE QUICK-CALL? (NAME)
 330         #DECL ((NAME) ATOM)
 331         <FIND-CALL .NAME ,GLUE-FCNS>>
 332
 333 <DEFINE CHANNEL-OP-GEN (TYPE OPER CHANNEL "TUPLE" ARGS
 334                         "AUX" (RES ,HAS-RESULT) FROB)
 335   #DECL ((TYPE OPER) ATOM (CHANNEL) VARTBL)
 336   <COND (<AND ,GLUE
 337               <SET FROB <CT-QUERY .TYPE .OPER>>
 338               <QUICK-CALL? .FROB>>
 339          ; "If we know what we're calling, and are compiling it, we'll make
 340             a glued call"
 341          <FRAME-GEN .FROB>)
 342         (T
 343          <SET FROB <>>
 344          <CALL-RTE ,IFRAME!-MIMOP CALL <> <>>)>
 345   <PUSH-VAR .CHANNEL>
 346   ; "Push channel"
 347   <PUSH-CONSTANT .OPER>
 348   ; "Push operation"
 349   <MAPF <>
 350     <FUNCTION (ARG)
 351       <COND (<TYPE? .ARG VARTBL>
 352              <PUSH-VAR .ARG>)
 353             (T
 354              <PUSH-CONSTANT .ARG>)>>
 355     .ARGS>
 356   ; "Push args"
 357   <FLUSH-ALL-ACS>
 358   <COND (.FROB
 359          ; "If glued call, go through normal code"
 360          <CALL-GEN .FROB <+ 2 <LENGTH .ARGS>> .RES>)
 361         (T
 362          <EMIT-MOVE
 363           <MA-DEF-DISP ,AC-M <+ <ADD-MVEC <CHTYPE (.TYPE .OPER) XCHANNEL-OP>>
 364                                 4>>
 365           <MA-REG ,AC-0> DOUBLE>
 366          ; "Get atom to call (1st element of funny list stored in mvector)"
 367          <EMIT-MOVE <MA-IMM <+ 2 <LENGTH .ARGS>>> <MA-REG ,AC-0> LONG>
 368          ; "Number of args"
 369          <EMIT ,INST-JSB <MA-ABS <CD-DISP-OFFSET ,MCALL!-MIMOP>>>
 370          ; "Do call"
 371          <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES <>>
 372          ; "Hack result"
 373          <CLEAR-STATUS>
 374          NORMAL)>>