<mdl.comp>/bits.mud.1

   1
   2 "MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
   3
   4 <DEFINE BIT-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (POSN 0) POS WIDTH)
   5         #DECL ((WIDTH POS NOD) NODE (K) <LIST [REST NODE]>)
   6         <COND (<SEGFLUSH .NOD .RTYP>)
   7               (ELSE
   8                <ARGCHK <LENGTH .K> '(1 2) BITS>
   9                <EANA <SET WIDTH <1 .K>> FIX BITS>
  10                <COND (<NOT <EMPTY? <REST .K>>>
  11                       <EANA <SET POS <2 .K>> FIX BITS>
  12                       <SET POSN <NODE-NAME .POS>>    ;"May be position field.")>
  13                <COND (<AND <==? <NODE-TYPE .WIDTH> ,QUOTE-CODE>
  14                            <OR <NOT <ASSIGNED? POS>>            ;"Only one arg."
  15                                <==? <NODE-TYPE .POS> ,QUOTE-CODE>>>
  16                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  17                       <PUT .NOD ,NODE-NAME <BITS <NODE-NAME .WIDTH> .POSN>>
  18                       <PUT .NOD ,KIDS ()>)
  19                      (ELSE <PUT .NOD ,NODE-TYPE ,BITS-CODE>)>)>
  20         <TYPE-OK? BITS .RTYP>>
  21
  22 <PUT ,BITS ANALYSIS ,BIT-ANA>
  23
  24 <DEFINE GETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 2 ,GETBITS-CODE>>
  25
  26 <PUT ,GETBITS ANALYSIS ,GETBITS-ANA>
  27
  28 <DEFINE PUTBITS-ANA (N R) <PGBITS .N .R '(2 3) ,PUTBITS-CODE>>
  29
  30 <PUT ,PUTBITS ANALYSIS ,PUTBITS-ANA>
  31
  32 <DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>) (NAM <NODE-NAME .NOD>))
  33         #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
  34         <COND (<SEGFLUSH .NOD .RTYP>)
  35               (ELSE
  36                <ARGCHK <LENGTH .K> .NARG .NAM>
  37                <PUT .NOD ,NODE-TYPE .COD>
  38                <EANA <1 .K>
  39                      <COND (<==? .COD ,GETBITS-CODE>
  40                             '<OR <PRIMTYPE WORD>
  41                                  <PRIMTYPE STORAGE>>)
  42                            (ELSE '<PRIMTYPE WORD>)>
  43                      .NAM>
  44                <EANA <2 .K> BITS .NAM>
  45                <IF <==? <LENGTH .K> 3>
  46                    <EANA <3 .K> '<PRIMTYPE WORD> .NAM>>)>
  47         <TYPE-OK? <COND (<==? .COD ,GETBITS-CODE> WORD)
  48                         (<ISTYPE? <RESULT-TYPE <1 .K>>>)
  49                         (ELSE '<PRIMTYPE WORD>)>
  50                   .RTYP>>
  51
  52 <DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>))
  53         #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
  54         <COND (<SEGFLUSH .NOD .RTYP>)
  55               (<0? .LN>
  56                <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  57                <PUT .NOD ,KIDS ()>
  58                <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
  59               (<1? .LN> <PUT .NOD ,NODE-TYPE ,ID-CODE>)
  60               (ELSE
  61                <PUT .NOD ,NODE-TYPE ,BITL-CODE>
  62                <MAPF <>
  63                      <FUNCTION (K1)
  64                              #DECL ((K1) NODE)
  65                              <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>>
  66                      .K>)>
  67         <TYPE-OK? WORD .RTYP>>
  68
  69 <PUT ,ANDB ANALYSIS ,BITLOG>
  70
  71 <PUT ,ORB ANALYSIS ,BITLOG>
  72
  73 <PUT ,XORB ANALYSIS ,BITLOG>
  74
  75 <PUT ,EQVB ANALYSIS ,BITLOG>
  76
  77 <DEFINE BITLOG-GEN (N W
  78                     "AUX" (K <KIDS .N>) (REG <UPDATE-WHERE .N .W>) (FST <1 .K>)
  79                           (INS <LGINS <NODE-SUBR .N>>))
  80         #DECL ((FST N) NODE (K) <LIST [REST NODE]> (REG) DATUM)
  81         <COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
  82                <PUT .K 1 <2 .K>>
  83                <PUT .K 2 .FST>)>
  84         <SET REG <GEN <1 .K> .REG>>
  85         <RET-TMP-AC <DATTYP .REG> .REG>
  86         <PUT .REG
  87              ,DATTYP
  88              <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE WORD)>>
  89         <MAPF <>
  90               <FUNCTION (NN "AUX" (NXT <GEN .NN DONT-CARE>) TT)
  91                       #DECL ((NN) NODE (NXT) DATUM)
  92                       <COND (<TYPE? <DATVAL .REG> AC>)
  93                             (<TYPE? <SET TT <DATVAL .NXT>> AC>
  94                              <PUT .NXT ,DATVAL <DATVAL .REG>>
  95                              <PUT .REG ,DATVAL .TT>
  96                              <FIX-ACLINK .TT .REG .NXT>)
  97                             (ELSE <TOACV .REG>)>
  98                       <PUT <SET TT <DATVAL .REG>> ,ACPROT T>
  99                       <MUNG-AC .TT .REG>
 100                       <IMCHK .INS <ACSYM .TT> <DATVAL .NXT> T>
 101                       <PUT .TT ,ACPROT <>>
 102                       <RET-TMP-AC .NXT>>
 103               <REST .K>>
 104         <MOVE:ARG .REG .W>>
 105
 106 <DEFINE LGINS (SUBR)
 107         <NTH '![(`AND  `ANDI `ANDCMI )
 108                 (`IOR  `IORI `ORCMI )
 109                 (`XOR  `XORI )
 110                 (`EQV  `EQVI )!]
 111              <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
 112
 113 <SETG LSUBRS ![,EQVB ,XORB ,ORB ,ANDB!]>
 114
 115 <DEFINE GETBITS-GEN (N W
 116                      "AUX" (WRDN <1 <KIDS .N>>) (BP <2 <KIDS .N>>) REG POS WDTH
 117                            BAC AC BPW WRD BPD TEM)
 118    #DECL ((WRDN N BP) NODE (POS WDTH) FIX (WRD REG BPD) DATUM (AC BAC) AC
 119           (BPW) <PRIMTYPE WORD>)
 120    <COND
 121     (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
 122      <SET WRD <GEN .WRDN DONT-CARE>>
 123      <SET BPW <NODE-NAME .BP>>
 124      <SET POS <CHTYPE <GETBITS .BPW #BITS *360600000000*> FIX>>
 125      <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
 126      <COND
 127       (<AND <==? <+ .POS .WDTH> 36>
 128             <N==? .WDTH 18>
 129             <TYPE? <DATVAL .WRD> AC>
 130             <NOT <ACRESIDUE <SET AC <DATVAL .WRD>>>>
 131             <OR <==? .W DONT-CARE>
 132                 <AND <TYPE? .W DATUM> <==? .AC <DATVAL .WRD>>>>>
 133        <MUNG-AC .AC <SET REG .WRD>>
 134        <EMIT <INSTRUCTION `LSH  <ACSYM .AC> <- .POS>>>)
 135       (ELSE
 136        <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
 137             ,ACPROT
 138             T>
 139        <COND (<AND <==? .WDTH 18>                    ;"Could be half word hack."
 140                    <COND (<0? .POS>
 141                           <EMIT <INSTRUCTION `HRRZ
 142                                              <ACSYM .AC>
 143                                              !<ADDR:VALUE .WRD>>>
 144                           T)
 145                          (<==? .POS 18>
 146                           <EMIT <INSTRUCTION `HLRZ
 147                                              <ACSYM .AC>
 148                                              !<ADDR:VALUE .WRD>>>
 149                           T)>>)
 150              (ELSE
 151               <EMIT <INSTRUCTION `LDB
 152                                  <ACSYM .AC>
 153                                  [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
 154                                         !<ADDR:VALUE .WRD>>]>>)>
 155        <PUT .AC ,ACPROT <>>
 156        <RET-TMP-AC .WRD>)>)
 157     (<==? <NODE-TYPE .BP> ,BITS-CODE>
 158      <SET WRD
 159           <GEN .WRDN
 160                <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
 161                      (ELSE DONT-CARE)>>>
 162      <SET BPD
 163           <1 <SET TEM <RBITS-GEN .BP <DATUM BITS ANY-AC> .WRD>>>>
 164      <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
 165           ,ACPROT
 166           T>
 167      <TOACV .BPD>
 168      <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
 169      <SET TEM <2 .TEM>>
 170      <PUT .TEM 1 <1 <ADDR:VALUE .WRD>>>
 171      <PUTREST .TEM <REST <ADDR:VALUE .WRD>>>
 172      <EMIT <INSTRUCTION `LDB  <ACSYM .AC> <ADDRSYM .BAC>>>
 173      <PUT .BAC ,ACPROT <>>
 174      <PUT .AC ,ACPROT <>>
 175      <RET-TMP-AC .WRD>
 176      <RET-TMP-AC .BPD>)
 177     (ELSE                                          ;"Non constant byte pointer."
 178      <SET WRD
 179           <GEN .WRDN
 180                <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
 181                      (ELSE DONT-CARE)>>>
 182      <SET BPD <GEN .BP DONT-CARE>>
 183      <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
 184           ,ACPROT
 185           T>
 186      <SET BPD <MOVE:ARG .BPD <DATUM BITS ANY-AC>>>
 187      <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
 188      <MUNG-AC .BAC .BPD>
 189      <EMIT <INSTRUCTION `HRRI  <ACSYM .BAC> !<ADDR:VALUE .WRD>>>
 190      <EMIT <INSTRUCTION `LDB  <ACSYM .AC> <ADDRSYM .BAC>>>
 191      <PUT .BAC ,ACPROT <>>
 192      <PUT .AC ,ACPROT <>>
 193      <RET-TMP-AC .WRD>
 194      <RET-TMP-AC .BPD>)>
 195    <MOVE:ARG .REG .W>>
 196
 197 <DEFINE PUTBITS-GEN (N W
 198                      "AUX" (K <KIDS .N>) (SWRD <1 .K>) (BP <2 .K>) BAC POS WDTH
 199                            FLD BPW BPD SWRDD (FLG T) TEM NUM)
 200    #DECL ((N SWRD BP) NODE (FLD BPD REG SWRDD) DATUM (AC BAC PAC) AC
 201           (POS WDTH) FIX (BPW) <PRIMTYPE WORD> (NUM) <OR FALSE FIX>)
 202    <COND
 203     (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
 204      <SET POS
 205           <CHTYPE <GETBITS <SET BPW <NODE-NAME .BP>> #BITS *360600000000*> FIX>>
 206      <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
 207      <COND
 208       (<AND <==? <NODE-TYPE .SWRD> ,QUOTE-CODE>
 209             <0? <CHTYPE <NODE-NAME .SWRD> FIX>>>
 210        <SET SWRDD <GEN <3 .K> <REG? <RESULT-TYPE .SWRD> .W>>>
 211        <MUNG-AC <DATVAL .SWRDD> .SWRDD>
 212        <COND (<L? <+ .POS .WDTH> 36>
 213               <IMCHK '(`AND  `ANDI )
 214                      <ACSYM <DATVAL .SWRDD>>
 215                      <REFERENCE:ADR <GETBITS -1 <BITS .WDTH>>>>)>
 216        <EMIT <INSTRUCTION `LSH  <ACSYM <DATVAL .SWRDD>> .POS>>)
 217       (ELSE
 218        <SET SWRDD
 219             <GEN .SWRD
 220                  <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)> .W>>>
 221        <MUNG-AC <DATVAL .SWRDD> .SWRDD>
 222        <COND
 223         (<AND
 224           <==? .WDTH 18>
 225           <COND
 226            (<0? .POS>
 227             <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
 228                    <EMIT <INSTRUCTION <COND (<0? .NUM> `HLLZS ) (ELSE `HLLOS )>
 229                                       <ADDRSYM <DATVAL .SWRDD>>>>)
 230                   (ELSE <PCLOB .SWRDD '(`HRR  `HRRI ) <3 .K>>)>)
 231            (<==? .POS 18>
 232             <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
 233                    <EMIT <INSTRUCTION <COND (<0? .NUM> `HRRZS ) (ELSE `HRROS )>
 234                                       <ADDRSYM <DATVAL .SWRDD>>>>)
 235                   (ELSE <PCLOB .SWRDD '(`HRL  `HRLI ) <3 .K>>)>
 236             T)>>)
 237         (<AND <OR <AND <L? .POS 18> <L=? <+ .POS .WDTH> 18>> <G? .POS 18>>
 238               <SET NUM <ZERQ .K>>
 239               <OR <0? .NUM> <L? .WDTH <POPWR2 <+ .NUM 1>>>>>
 240          <EMIT <INSTRUCTION <COND (<0? .NUM>
 241                                    <COND (<L? .POS 18> `ANDCMI ) (ELSE `TLZ )>)
 242                                   (ELSE
 243                                    <COND (<L? .POS 18> `IORI ) (ELSE `TLO )>)>
 244                             <ACSYM <DATVAL .SWRDD>>
 245                             <LSH <LSH -1 <- .WDTH 36>>
 246                                  <COND (<L? .POS 18> .POS)
 247                                        (ELSE <- .POS 18>)>>>>)
 248         (ELSE
 249          <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>
 250          <PUT <DATVAL .FLD> ,ACPROT T>
 251          <TOACV .SWRDD>
 252          <PUT <DATVAL .SWRDD> ,ACPROT T>
 253          <EMIT <INSTRUCTION `DPB
 254                             <ACSYM <DATVAL .FLD>>
 255                             [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
 256                                    <ADDRSYM <DATVAL .SWRDD>>>]>>
 257          <PUT <DATVAL .FLD> ,ACPROT <>>
 258          <PUT <DATVAL .SWRDD> ,ACPROT <>>
 259          <RET-TMP-AC .FLD>)>)>)
 260     (ELSE
 261      <COND (<NOT <AND <NOT <SIDE-EFFECTS .N>> <MEMQ <NODE-TYPE .SWRD> ,SNODES>>>
 262             <SET SWRDD
 263                  <GEN .SWRD
 264                       <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
 265                             .W>>>)>
 266      <PREFER-DATUM .W>
 267      <SET BPD
 268           <COND (<==? <NODE-TYPE .BP> ,BITS-CODE>
 269                  <SET FLG <>>
 270                  <1 <SET TEM
 271                          <RBITS-GEN .BP
 272                                     <DATUM BITS ANY-AC>
 273                                     <COND (<ASSIGNED? SWRDD> .SWRDD)
 274                                           (ELSE ,NO-DATUM)>>>>)
 275                 (ELSE <GEN .BP DONT-CARE>)>>
 276      <PREFER-DATUM .W>
 277      <COND (<SET NUM <ZERQ .K>>
 278             <SET FLD <MOVE:ARG <REFERENCE .NUM> <DATUM WORD ANY-AC>>>)
 279            (ELSE <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>)>
 280      <DATTYP-FLUSH .FLD>
 281      <PUT .FLD ,DATTYP WORD>
 282      <COND (<NOT <ASSIGNED? SWRDD>>
 283             <SET SWRDD
 284                  <GEN .SWRD
 285                       <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
 286                             .W>>>)>
 287      <COND (<NOT <TYPE? <DATVAL .SWRDD> AC>>
 288             <SET SWRDD
 289                  <MOVE:ARG
 290                   .SWRDD
 291                   <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
 292                         .W>>>)>
 293      <PUT <DATVAL .SWRDD> ,ACPROT T>
 294      <TOACV .FLD>
 295      <PUT <DATVAL .FLD> ,ACPROT T>
 296      <TOACV .BPD>
 297      <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
 298      <COND (<NOT .FLG>
 299             <PUT <2 .TEM> 1 <ADDRSYM <DATVAL .SWRDD>>>
 300             <PUTREST <2 .TEM> ()>)>
 301      <MUNG-AC <DATVAL .SWRDD> .SWRDD>
 302      <COND (.FLG
 303             <MUNG-AC .BAC .BPD>
 304             <EMIT <INSTRUCTION `HRRI  <ACSYM .BAC> <ADDRSYM <DATVAL .SWRDD>>>>)>
 305      <EMIT <INSTRUCTION `DPB  <ACSYM <DATVAL .FLD>> <ADDRSYM .BAC>>>
 306      <PUT .BAC ,ACPROT <>>
 307      <PUT <DATVAL .SWRDD> ,ACPROT <>>
 308      <PUT <DATVAL .FLD> ,ACPROT <>>
 309      <RET-TMP-AC .BPD>
 310      <RET-TMP-AC .FLD>)>
 311    <MOVE:ARG .SWRDD .W>>
 312
 313 <DEFINE ZERQ (L "AUX" NUM)
 314         #DECL ((L) <LIST [REST NODE]>)
 315         <COND (<==? <LENGTH .L> 2> 0)
 316               (<AND <==? <NODE-TYPE <SET NUM <3 .L>>> ,QUOTE-CODE>
 317                     <==? <PRIMTYPE <SET NUM <NODE-NAME .NUM>>> WORD>
 318                     <OR <AND <0? <SET NUM <CHTYPE .NUM FIX>>> 0>
 319                         <AND <POPWR2 <+ .NUM 1>> .NUM>>>)>>
 320
 321 <DEFINE PCLOB (DEST INS SRC "AUX" SRCD)
 322         #DECL ((DEST SRCD) DATUM (SRC) NODE)
 323         <SET SRCD <GEN .SRC DONT-CARE>>
 324         <TOACV .DEST>
 325         <PUT <DATVAL .DEST> ,ACPROT T>
 326         <IMCHK .INS <ACSYM <DATVAL .DEST>> <DATVAL .SRCD>>
 327         <PUT <DATVAL .DEST> ,ACPROT <>>
 328         <RET-TMP-AC .SRCD>>
 329
 330 <DEFINE BITS-GEN (N W) <1 <RBITS-GEN .N .W DONT-CARE>>>
 331
 332 <DEFINE RBITS-GEN (N W ADDR
 333                    "AUX" (K <KIDS .N>) (WDTHN <1 .K>) WDTH POS TEM
 334                          (REG <REG? WORD .W>) POSD (FLG T))
 335         #DECL ((POS N WDTHN) NODE (REG WDTH POSD) DATUM (K) <LIST [REST NODE]>)
 336         <COND (<==? <LENGTH .K> 2> <SET POS <2 .K>>)>
 337         <COND
 338          (<==? <NODE-TYPE .WDTHN> ,QUOTE-CODE>
 339           <SET TEM <MAKE-PTR .ADDR T <NODE-NAME .WDTHN>>>)
 340          (<OR <NOT <ASSIGNED? POS>>
 341               <==? <NODE-TYPE .POS> ,QUOTE-CODE>>
 342           <SET TEM
 343                <MAKE-PTR .ADDR
 344                          <>
 345                          <COND (<ASSIGNED? POS> <NODE-NAME .POS>) (ELSE 0)>>>
 346           <SET POS .WDTHN>
 347           <SET FLG <>>)
 348          (ELSE
 349           <SET WDTH <GEN .WDTHN .REG>>
 350           <MUNG-AC <DATVAL .REG> .REG>
 351           <EMIT <INSTRUCTION `LSH  <ACSYM <DATVAL .REG>> 24>>
 352           <COND (<TYPE? .ADDR DATUM>
 353                  <EMIT <SET TEM <INSTRUCTION `HRRI  <ACSYM <DATVAL .REG>> 0>>>
 354                  <SET TEM <REST .TEM 2>>)
 355                 (ELSE <SET TEM '(0)>)>)>
 356         <SET POSD <GEN .POS <DATUM WORD ANY-AC>>>
 357         <PUT <DATVAL .POSD> ,ACPROT T>
 358         <COND (<NOT <ASSIGNED? WDTH>>
 359                <SET WDTH <DATUM WORD ANY-AC>>
 360                <PUT .WDTH ,DATVAL <GETREG .WDTH>>
 361                <EMIT <INSTRUCTION `MOVE  <ACSYM <DATVAL .WDTH>> .TEM>>
 362                <SET TEM <REST <1 .TEM>>>)
 363               (ELSE <TOACV .WDTH>)>
 364         <PUT <DATVAL .WDTH> ,ACPROT T>
 365         <EMIT <INSTRUCTION `DPB
 366                            <ACSYM <DATVAL .POSD>>
 367                            [<FORM (<COND (.FLG 123264) (ELSE 98688)>)
 368                                   <ADDRSYM <DATVAL .WDTH>>>]>>
 369         <PUT <DATVAL .WDTH> ,ACPROT <>>
 370         <PUT <DATVAL .POSD> ,ACPROT <>>
 371         <RET-TMP-AC .POSD>
 372         <COND (<TYPE? <DATTYP .WDTH> AC>
 373                <RET-TMP-AC <DATTYP .WDTH> .WDTH>)>
 374         <PUT .WDTH ,DATTYP BITS>
 375         [<MOVE:ARG .WDTH .W> .TEM]>
 376
 377 <DEFINE MAKE-PTR (AD W-P CNST "AUX" (BP <BITS 6 <COND (.W-P 24) (ELSE 30)>>))
 378         #DECL ((CNST) FIX)
 379         <COND (<TYPE? .AD DATUM>
 380                [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) HERE>])
 381               (ELSE
 382                [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) 0>])>>
 383 \f