home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / i386 / lapopt.scm < prev    next >
Text File  |  1999-01-02  |  12KB  |  375 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lapopt.scm,v 1.6 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1992-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; LAP Optimizer for Intel i386.
  23. ;;; package: (compiler lap-optimizer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (optimize-linear-lap instructions)
  28.   (rewrite-lap instructions))
  29.  
  30. ;; i386 LAPOPT uses its own pattern matcher because we want to match
  31. ;; patterns while ignoring comments.
  32.  
  33. (define (comment? thing)
  34.   (and (pair? thing) (eq? (car thing) 'COMMENT)))
  35.  
  36. (define (match pat thing dict)        ; -> #F or dictionary (alist)
  37.   (if (pair? pat)
  38.       (if (eq? (car pat) '?)
  39.       (cond ((assq (cadr pat) dict)
  40.          => (lambda (pair)
  41.               (and (equal? (cdr pair) thing)
  42.                dict)))
  43.         (else (cons (cons (cadr pat) thing) dict)))
  44.       (and (pair? thing)
  45.            (let ((dict* (match (car pat) (car thing) dict)))
  46.          (and dict*
  47.               (match (cdr pat) (cdr thing) dict*)))))
  48.       (and (eqv? pat thing)
  49.        dict)))
  50.  
  51. (define (match-sequence pats things dict comments success fail)
  52.   ;; SUCCESS = (lambda (dict* comments* things-tail) ...)
  53.   ;; FAIL =  (lambda () ...)
  54.  
  55.   (define (eat-comment)
  56.     (match-sequence pats (cdr things) dict (cons (car things) comments)
  57.             success fail))
  58.  
  59.   (cond ((not (pair? pats))        ; i.e. null
  60.      (if (and (pair? things)
  61.           (comment? (car things)))
  62.          (eat-comment)
  63.          (success dict comments things)))
  64.     ((not (pair? things))
  65.      (fail))
  66.     ((comment? (car things))
  67.      (eat-comment))
  68.     ((match (car pats) (car things) dict)
  69.      => (lambda (dict*)
  70.           (match-sequence (cdr pats) (cdr things) dict* comments
  71.                   success fail)))
  72.     (else (fail))))
  73.  
  74. (define-structure
  75.     (rule)
  76.   name                    ; used only for information
  77.   pattern                ; INSNs (in reverse order)
  78.   predicate                ; (lambda (dict) ...) -> bool
  79.   constructor)                ; (lambda (dict) ...) -> lap
  80.  
  81. (define *rules* (make-eq-hash-table))
  82.  
  83.  
  84. ;; Rules are indexed by the last opcode in the pattern.
  85.  
  86. (define (define-lapopt name pattern predicate constructor)
  87.   (let ((pattern (reverse pattern)))
  88.     (let ((rule (make-rule name
  89.                pattern
  90.                (if ((access procedure? system-global-environment)
  91.                 predicate)
  92.                    predicate
  93.                    (lambda (dict) dict #T))
  94.                constructor)))
  95.       (if (or (not (pair? pattern))
  96.           (not (pair? (car pattern))))
  97.       (error "Illegal LAPOPT pattern - must end with opcode"
  98.          (reverse pattern)))
  99.       (let ((key (caar pattern)))
  100.     (hash-table/put! *rules* key
  101.              (cons rule (hash-table/get *rules* key '()))))))
  102.   name)
  103.  
  104. (define (find-rules instruction)
  105.   (hash-table/get *rules* (car instruction) '()))
  106.   
  107. ;; Rules are tried in the reverse order in which they are defined.
  108. ;;
  109. ;; Rules are matched against the LAP from the bottom up.
  110. ;;
  111. ;; Once a rule has been applied, the rewritten LAP is matched again,
  112. ;; so a rule must rewrite to something different to avoid a loop.
  113. ;; (One way to ensure this is to always rewrite to fewer instructions.)
  114.  
  115. (define (rewrite-lap lap)
  116.   (let loop ((unseen (reverse lap)) (finished '()))
  117.     (if (null? unseen)
  118.     finished
  119.     (if (comment? (car unseen))
  120.         (loop (cdr unseen) (cons (car unseen) finished))
  121.         (let try-rules ((rules (find-rules (car unseen))))
  122.           (if (null? rules)
  123.           (loop (cdr unseen) (cons (car unseen) finished))
  124.           (let ((rule (car rules)))
  125.             (match-sequence
  126.              (rule-pattern rule)
  127.              unseen
  128.              '(("empty"))    ; initial dict, distinct from #F and ()
  129.              '()        ; initial comments
  130.              (lambda (dict comments unseen*)
  131.                (let ((dict (alist->dict dict)))
  132.              (if ((rule-predicate rule) dict)
  133.                  (let ((rewritten
  134.                     (cons
  135.                      `(COMMENT (LAP-OPT ,(rule-name rule)))
  136.                      (append comments
  137.                          ((rule-constructor rule) dict)))))
  138.                    (loop (append (reverse rewritten) unseen*)
  139.                      finished))
  140.                  (try-rules (cdr rules)))))
  141.              (lambda ()
  142.                (try-rules (cdr rules)))))))))))
  143.  
  144. ;; The DICT passed to the rule predicate and action procedures is a
  145. ;; procedure mapping pattern names to their matched values.
  146.  
  147. (define (alist->dict dict)
  148.   (lambda (symbol)
  149.     (cond ((assq symbol dict) => cdr)
  150.       (else (error "Undefined lapopt pattern symbol" symbol dict)))))
  151.  
  152.  
  153. (define-lapopt 'PUSH-POP->MOVE
  154.   `((PUSH (? reg1))
  155.     (POP  (? reg2)))
  156.   #F
  157.   (lambda (dict)
  158.     `((MOV W ,(dict 'reg2) ,(dict 'reg1)))))
  159.  
  160. (define-lapopt 'PUSH-POP->NOP
  161.   `((PUSH (? reg))
  162.     (POP  (? reg)))
  163.   #F
  164.   (lambda (dict)
  165.     dict
  166.     `()))
  167.  
  168. ;; The following rules must have the JMP else we don't know if the
  169. ;; register that we are avoiding loading is dead.
  170.  
  171. (define-lapopt 'LOAD-PUSH-POP-JUMP->REGARGETTED-LOAD-JUMP
  172.   ;; Note that reg1 must match a register because of the PUSH insn.
  173.   `((MOV W (? reg1) (? ea/value))
  174.     (PUSH (? reg1))
  175.     (POP  (R ,ecx))
  176.     (JMP (@RO B 6 (? hook-offset))))
  177.   #F
  178.   (lambda (dict)
  179.     `((MOV W (R ,ecx) ,(dict 'ea/value))
  180.       (JMP (@RO B 6 ,(dict 'hook-offset))))))
  181.  
  182. (define-lapopt 'LOAD-STACKTOPWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP
  183.   `((MOV W (? reg) (? ea/value))
  184.     (MOV W (@r ,esp) (? reg))
  185.     (POP (R ,ecx))
  186.     (JMP (@RO B 6 (? hook-offset))))
  187.   #F
  188.   (lambda (dict)
  189.     `((MOV W (R ,ecx) ,(dict 'ea/value))
  190.       (ADD W (R ,esp) (& 4))
  191.       (JMP (@RO B 6 ,(dict 'hook-offset))))))
  192.  
  193.  
  194. (define-lapopt 'STACKWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP
  195.   `((MOV W (@RO B ,esp (? stack-offset)) (? ea/value))
  196.     (ADD W (R ,esp) (& (? stack-offset)))
  197.     (POP (R ,ecx))
  198.     (JMP (@RO B 6 (? hook-offset))))
  199.   #F
  200.   (lambda (dict)
  201.     `((MOV W (R ,ecx) ,(dict 'ea/value))
  202.       (ADD W (R ,esp) (& ,(+ 4 (dict 'stack-offset))))
  203.       (JMP (@RO B 6 ,(dict 'hook-offset))))))
  204.  
  205.  
  206.  
  207. ;; The following rules recognize arithmetic followed by tag injection,
  208. ;; and fold the tag-injection into the arithmetic.  We can do this
  209. ;; because we know the bottom six bits of the fixnum are all 0.  This
  210. ;; is particularly crafty in the generic arithmetic case, as it does
  211. ;; not mess up the overflow detection.
  212. ;;
  213. ;; These patterns match the code generated by subtractions too.
  214.  
  215. (define fixnum-tag (object-type 1))
  216.  
  217. (define-lapopt 'FIXNUM-ADD-CONST-TAG
  218.   `((ADD W (R (? reg)) (& (? const)))
  219.     (OR W (R (? reg)) (& ,fixnum-tag))
  220.     (ROR W (R (? reg)) (& 6)))
  221.   #F
  222.   (lambda (dict)
  223.     `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag)))
  224.       (ROR W (R ,(dict 'reg)) (& 6)))))
  225.  
  226. (define-lapopt 'FIXNUM-ADD-REG-TAG
  227.   `((ADD W (R (? reg)) (R (? reg-2)))
  228.     (OR W (R (? reg)) (& ,fixnum-tag))
  229.     (ROR W (R (? reg)) (& 6)))
  230.   #F
  231.   (lambda (dict)
  232.     `((LEA (R ,(dict 'reg)) (@ROI B ,(dict 'reg) ,fixnum-tag ,(dict 'reg-2) 1))
  233.       (ROR W (R ,(dict 'reg)) (& 6)))))
  234.  
  235. (define-lapopt 'GENERIC-ADD-TAG
  236.   `((ADD W (R (? reg)) (& (? const)))
  237.     (JO (@PCR (? label)))
  238.     (OR W (R (? reg)) (& ,fixnum-tag))
  239.     (ROR W (R (? reg)) (& 6)))
  240.   #F
  241.   (lambda (dict)
  242.     `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag)))
  243.       (JO (@PCR ,(dict 'label)))
  244.       (ROR W (R ,(dict 'reg)) (& 6)))))
  245.  
  246. ;; If the fixnum tag is even, the zero LSB works as a place to hold
  247. ;; the overflow from addition which can be discarded by masking it
  248. ;; out.  We must arrange that the constant is positive, so we don't
  249. ;; borrow from the tag bits.
  250.  
  251. (if (even? fixnum-tag)
  252.     (define-lapopt 'FIXNUM-ADD-CONST-IN-PLACE
  253.       `((SAL W (? reg) (& ,scheme-type-width))
  254.     (ADD W (? reg) (& (? const)))
  255.     (OR W (? reg)  (& ,fixnum-tag))
  256.     (ROR W (? reg) (& ,scheme-type-width)))
  257.       #F
  258.       (lambda (dict)
  259.     (let ((const (sar-32 (dict 'const) scheme-type-width))
  260.           (mask  (make-non-pointer-literal
  261.               fixnum-tag
  262.               (-1+ (expt 2 scheme-datum-width)))))
  263.       (let ((const
  264.          (if (negative? const)
  265.              (+ const (expt 2 scheme-datum-width))
  266.              const)))
  267.         `(,(if (= const 1)
  268.            `(INC W ,(dict 'reg)) ; shorter instruction
  269.            `(ADD W ,(dict 'reg) (& ,const)))
  270.           (AND W ,(dict 'reg) (& ,mask))))))))
  271.  
  272. ;; Similar tag-injection combining rule for fix:or is a little more
  273. ;; general.
  274.  
  275. (define (or-32-signed x y)
  276.   (bit-string->signed-integer
  277.    (bit-string-or (signed-integer->bit-string 32 x)
  278.           (signed-integer->bit-string 32 y))))
  279.  
  280. (define (ror-32-signed w count)
  281.   (let ((bs (signed-integer->bit-string 32 w)))
  282.     (bit-string->signed-integer
  283.      (bit-string-append (bit-substring bs count 32)
  284.             (bit-substring bs 0 count)))))
  285.  
  286. (define (sar-32 w count)
  287.   (let ((bs (signed-integer->bit-string 32 w)))
  288.     (bit-string->signed-integer (bit-substring bs count 32))))
  289.  
  290. (define-lapopt 'OR-OR
  291.   `((OR W (R (? reg)) (& (? const-1)))
  292.     (OR W (R (? reg)) (& (? const-2))))
  293.   #F
  294.   (lambda (dict)
  295.     `((OR W (R ,(dict 'reg))
  296.       (& ,(or-32-signed (dict 'const-1) (dict 'const-2)))))))
  297.  
  298. ;; These rules match a whole fixnum detag-AND/OR-retag operation.  In
  299. ;; principle, these operations could be done in rulfix.scm, but the
  300. ;; instruction combiner wants all the intermediate steps.
  301.  
  302. (define-lapopt 'FIXNUM-OR-CONST-IN-PLACE
  303.   `((SAL W (? reg) (& ,scheme-type-width))
  304.     (OR W (? reg) (& (? const)))
  305.     (OR W (? reg) (& ,fixnum-tag))
  306.     (ROR W (? reg) (& ,scheme-type-width)))
  307.   #F
  308.   (lambda (dict)
  309.     `((OR W ,(dict 'reg)
  310.       (& ,(careful-object-datum
  311.            (sar-32 (dict 'const) scheme-type-width)))))))
  312.  
  313. (define-lapopt 'FIXNUM-AND-CONST-IN-PLACE
  314.   `((SAL W (? reg) (& ,scheme-type-width))
  315.     (AND W (? reg) (& (? const)))
  316.     (OR W (? reg) (& ,fixnum-tag))
  317.     (ROR W (? reg) (& ,scheme-type-width)))
  318.   #F
  319.   (lambda (dict)
  320.     `((AND W ,(dict 'reg)
  321.        (& ,(make-non-pointer-literal
  322.         fixnum-tag
  323.         (careful-object-datum
  324.          (sar-32 (dict 'const) scheme-type-width))))))))
  325.  
  326. ;; FIXNUM-NOT.  The first (partial) pattern uses the XOR operation to
  327. ;; put the tag bits in the low part of the result.  This pattern
  328. ;; occurs in the hash table hash functions, where the OBJECT->FIXNUM
  329. ;; has been shared by CSE.
  330.  
  331. (define-lapopt 'FIXNUM-NOT-TAG
  332.   `((NOT W (? reg))
  333.     (AND W (? reg) (& #x-40))
  334.     (OR W (? reg) (& ,fixnum-tag))
  335.     (ROR W (? reg) (& ,scheme-type-width)))
  336.   #F
  337.   (lambda (dict)
  338.     (let ((magic-bits (+ (* -1 (expt 2 scheme-type-width)) fixnum-tag)))
  339.       `((XOR W ,(dict 'reg) (& ,magic-bits))
  340.     (ROR W ,(dict 'reg) (& ,scheme-type-width))))))
  341.  
  342. (define-lapopt 'FIXNUM-NOT-IN-PLACE
  343.   `((SAL W (? reg) (& ,scheme-type-width))
  344.     (NOT W (? reg))
  345.     (AND W (? reg) (& #x-40))
  346.     (OR W (? reg) (& ,fixnum-tag))
  347.     (ROR W (? reg) (& ,scheme-type-width)))
  348.   #F
  349.   (lambda (dict)
  350.     `((XOR W ,(dict 'reg) (& ,(-1+ (expt 2 scheme-datum-width)))))))
  351.  
  352.  
  353. ;; CLOSURES
  354. ;;
  355. ;; This rule recognizes code duplicated at the end of the CONS-CLOSURE
  356. ;; and CONS-MULTICLOSURE and the following CONS-POINTER. (This happens
  357. ;; because of the hack of storing the entry point as a tagged object
  358. ;; in the closure to allow GC to work correctly with relative jumps in
  359. ;; the closure code.  A better fix would be to alter the GC to make
  360. ;; absolute the addresses during closure transport.)
  361. ;;
  362. ;; The rule relies on the fact the REG-TEMP is a temporary for the
  363. ;; expansions of CONS-CLOSURE and CONS-MULTICLOSURE, so it is dead
  364. ;; afterwards, and is specific in matching because it is the only code
  365. ;; that stores an entry at a negative offset from the free pointer.
  366.  
  367. (define-lapopt 'CONS-CLOSURE-FIXUP
  368.   `((LEA (? reg-temp) (@RO UW (? regno-closure) #xA0000000))
  369.     (MOV W (@RO B ,regnum:free-pointer -4) (? regno-temp))
  370.     (LEA (? reg-object) (@RO UW (? regno-closure) #xA0000000)))
  371.   #F
  372.   (lambda (dict)
  373.     `((LEA ,(dict 'reg-object) (@RO UW ,(dict 'regno-closure) #xA0000000))
  374.       (MOV W (@RO B ,regnum:free-pointer -4) ,(dict 'reg-object)))))
  375.