1;;; 2;;; compile-i.scm - Inliners of builtin procedures 3;;; 4;;; Copyright (c) 2004-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; If the subr has a directly corresponding VM instruction, the 35;; inlining direction is embedded within the subr definition in 36;; the stub file. The inliners below deal with more complex 37;; situations. 38 39;; Some operations (e.g. NUMADD2) has specialized instructions when 40;; one of the operands has certain properties (e.g. if one of the operand 41;; is a small exact integer, NUMADDI can be used). Such choice of 42;; instructions are done in Pass 5 $ASM handler, since they may have 43;; more information. The inliner can emit a generic instruction and 44;; leave the choice of specialized instructions to the later stage. 45 46;; Defines builtin inliner for the existing SUBRs. 47;; The binding of NAME must be visible from gauche.internal. 48(define-macro (define-builtin-inliner name proc) 49 (let1 debug-name (string->symbol #"inliner/~name") 50 `(let1 ,debug-name ,proc 51 (set! (%procedure-inliner ,name) ,debug-name) 52 (%mark-binding-inlinable! (find-module 'gauche.internal) ',name)))) 53 54;; Generate two argument call of assembler insn INSN unconditionally 55(define (gen-inliner-arg2 insn) 56 (^[src args] 57 (match args 58 [(x y) ($asm src (list insn) (list x y))] 59 [else (undefined)]))) 60 61;; If the form has two arg and the latter arg is a constant exact integer 62;; that fits insn arg, generate ***I type insn. If both args are constant, 63;; replace the form with ($const (proc x y)). Otherwise give up. 64(define (gen-inliner-argi insn proc) 65 (^[src args] 66 (match args 67 [(n cnt) 68 (let ([cnt-val (check-numeric-constant cnt)] 69 [n-val (check-numeric-constant n)]) 70 (cond [(and cnt-val n-val) ($const (proc n-val cnt-val))] 71 [(and cnt-val (integer-fits-insn-arg? cnt-val)) 72 ($asm src `(,insn ,cnt-val) (list n))] 73 [else (undefined)]))] 74 [else (undefined)]))) 75 76(inline-stub 77 (define-cproc %procedure-inliner (proc::<procedure>) 78 (setter (proc::<procedure> inliner) ::<void> 79 (set! (-> proc inliner) inliner)) 80 (return (?: (-> proc inliner) (-> proc inliner) '#f))) 81 82 (define-cproc %mark-binding-inlinable! (mod::<module> name::<symbol>) ::<void> 83 (let* ([g::ScmGloc* (Scm_FindBinding mod name 0)]) 84 (unless g 85 (Scm_Error "[internal] %%mark-binding-inlinable!: \ 86 no such binding for %S in %S" 87 (SCM_OBJ name) (SCM_OBJ mod))) 88 (Scm_GlocMark g SCM_BINDING_INLINABLE))) 89 ) 90 91;;-------------------------------------------------------- 92;; Inlining numeric operators 93;; 94 95;; (1) VM insturctions are usually binary where the corresponding 96;; Scheme operators are variable arity. We analyze the arguments 97;; and generate a (possibly nested) $asm clause. 98;; 99;; (2) We try to fold constant operations. Constant numbers may appear 100;; literally, or a result of constant-variable compilation or other 101;; constant folding. Except the literal numbers we need to call 102;; pass1 first on the argument to see if we can get a constant. 103 104;; Returns numeric value if iform is a constant number. 105(define (check-numeric-constant iform) 106 (and ($const? iform) 107 (number? ($const-value iform)) 108 ($const-value iform))) 109 110(define (ensure-inexact-const numconstval) 111 ($const (inexact numconstval))) 112 113(define-macro (fold-asm src op insn const x y more) 114 `(let loop ([x ,x] [y ,y] [more ,more]) 115 (let ([xval (check-numeric-constant x)] 116 [yval (check-numeric-constant y)]) 117 (let1 v (if (and xval yval) 118 (,const (,op xval yval)) 119 ($asm ,src `(,,insn) `(,,'x ,,'y))) 120 (if (null? more) v (loop v (car more) (cdr more))))))) 121 122(define-macro (define-builtin-inliner-+* op unit insn const) 123 `(define-builtin-inliner ,op 124 (^[src args] 125 (match args 126 [() (,const ,unit)] 127 [(x) (if-let1 val (check-numeric-constant x) 128 (,const val) 129 (undefined))] ; let it be handled at runtime 130 [(x y . more) (fold-asm src ,op ,insn ,const x y more)])))) 131 132(define-builtin-inliner-+* + 0 NUMADD2 $const) 133(define-builtin-inliner-+* +. 0 NUMIADD2 ensure-inexact-const) 134(define-builtin-inliner-+* * 1 NUMMUL2 $const) 135(define-builtin-inliner-+* *. 1 NUMIMUL2 ensure-inexact-const) 136 137(define-macro (define-builtin-inliner--/ op insn const) 138 `(define-builtin-inliner ,op 139 (^[src args] 140 (match args 141 [() (error "procedure requires at least one argument:" src)] 142 [(x) (if-let1 val (check-numeric-constant x) 143 (,const (,op val)) 144 ,(if (eq? op '-) 145 `($asm src `(,NEGATE) (list x)) 146 (undefined)))] ; let it be handled at runtime 147 [(x y . more) (fold-asm src ,op ,insn ,const x y more)])))) 148 149(define-builtin-inliner--/ - NUMSUB2 $const) 150(define-builtin-inliner--/ -. NUMISUB2 ensure-inexact-const) 151(define-builtin-inliner--/ /. NUMIDIV2 ensure-inexact-const) 152 153;; NB: If we detect exact division-by-zero case, we shouldn't fold 154;; the constant and let it be handled at runtime. 155(define-builtin-inliner / 156 (^[src args] 157 (match args 158 [() (error "procedure requires at least one argument:" src)] 159 [(x) (let1 val (check-numeric-constant x) 160 (if (and val (not (eqv? val 0))) 161 ($const (/ val)) 162 (undefined)))] 163 [(x y . more) 164 ;; can't use fold-asm here because of exact zero check 165 (let loop ([x x] [y y] [more more]) 166 (let ([xval (check-numeric-constant x)] 167 [yval (check-numeric-constant y)]) 168 (let1 v (if (and xval yval (not (and (eqv? yval 0) (exact? xval)))) 169 ($const (/ xval yval)) 170 ($asm src `(,NUMDIV2) `(,x ,y))) 171 (if (null? more) v (loop v (car more) (cdr more))))))]))) 172 173(define-builtin-inliner = (gen-inliner-arg2 NUMEQ2)) 174(define-builtin-inliner < (gen-inliner-arg2 NUMLT2)) 175(define-builtin-inliner <= (gen-inliner-arg2 NUMLE2)) 176(define-builtin-inliner > (gen-inliner-arg2 NUMGT2)) 177(define-builtin-inliner >= (gen-inliner-arg2 NUMGE2)) 178 179(define-builtin-inliner modulo (gen-inliner-argi NUMMODI modulo)) 180(define-builtin-inliner remainder (gen-inliner-argi NUMREMI remainder)) 181(define-builtin-inliner ash (gen-inliner-argi ASHI ash)) 182 183;; bitwise and, ior and xor. we treat (op expr const) case specially. 184(define (builtin-inliner-bitwise opname op opcode unit) 185 ;; Classify the arguments to (integer) constants and non-constants. 186 ;; Integer constants are folded. Returns cons of the folded constant 187 ;; (#f if no constant argument), and the list of iforms for the rest 188 ;; of arguments. 189 (define (classify-args args) 190 (let loop ([args args] [constval #f] [iforms '()]) 191 (if (null? args) 192 (cons constval iforms) 193 (let1 val (check-numeric-constant (car args)) 194 (if (and val (exact-integer? val)) 195 (loop (cdr args) (if constval (op constval val) val) iforms) 196 (loop (cdr args) constval (cons (car args) iforms))))))) 197 198 (^[src args] 199 (match (classify-args args) 200 [(#f) ($const unit)] 201 [(constval) ($const constval)] 202 [(constval x) ($asm src `(,opcode) (list ($const constval) x))] 203 [(#f x y) ($asm src `(,opcode) (list x y))] 204 [_ (undefined)]))) 205 206(define-builtin-inliner logand 207 (builtin-inliner-bitwise 'logand logand LOGAND -1)) 208(define-builtin-inliner logior 209 (builtin-inliner-bitwise 'logior logior LOGIOR 0)) 210(define-builtin-inliner logxor 211 (builtin-inliner-bitwise 'logxor logxor LOGXOR 0)) 212 213;;-------------------------------------------------------- 214;; Inlining other operators 215;; 216 217(define-builtin-inliner vector-ref 218 (^[src args] 219 (match args 220 [(vec ind) ($asm src `(,VEC-REF) (list vec ind))] 221 [else (undefined)]))) 222 223(define-builtin-inliner vector-set! 224 (^[src args] 225 (match args 226 [(vec ind val) ($asm src `(,VEC-SET) `(,vec ,ind ,val))] 227 [else (error "wrong number of arguments for vector-set!:" src)]))) 228 229(define-macro (define-builtin-inliner-uvref tag TAG) 230 (let ([%-ref (symbol-append tag 'vector-ref)] 231 [%type (symbol-append 'SCM_UVECTOR_ TAG)]) 232 `(define-builtin-inliner ,%-ref 233 (^[src args] 234 (match args 235 [(vec ind) ($asm src `(,UVEC-REF ,,%type) `(,vec ,ind))] 236 [else (undefined)]))))) 237 238(define-builtin-inliner-uvref s8 S8) 239(define-builtin-inliner-uvref u8 U8) 240(define-builtin-inliner-uvref s16 S16) 241(define-builtin-inliner-uvref u16 U16) 242(define-builtin-inliner-uvref s32 S32) 243(define-builtin-inliner-uvref u32 U32) 244(define-builtin-inliner-uvref s64 S64) 245(define-builtin-inliner-uvref u64 U64) 246(define-builtin-inliner-uvref f16 F16) 247(define-builtin-inliner-uvref f32 F32) 248(define-builtin-inliner-uvref f64 F64) 249 250(define-builtin-inliner zero? 251 (^[src args] 252 (match args 253 [(arg) ($asm src `(,NUMEQ2) `(,arg ,($const 0)))] 254 [else (error "wrong number of arguments for zero?:" src)]))) 255 256(define-builtin-inliner acons 257 (^[src args] 258 (match args 259 [(a b c) ($asm src `(,CONS) `(,($asm #f `(,CONS) `(,a ,b)) ,c))] 260 [else (error "wrong number of arguments for acons:" src)]))) 261 262(define-builtin-inliner reverse 263 (^[src args] 264 (match args 265 [(a) ($asm src `(,REVERSE) `(,a))] 266 [else (undefined)]))) 267 268(define-builtin-inliner current-input-port 269 (^[src args] 270 (match args 271 [() ($asm src `(,CURIN) '())] 272 [else (undefined)]))) 273 274(define-builtin-inliner current-output-port 275 (^[src args] 276 (match args 277 [() ($asm src `(,CUROUT) '())] 278 [else (undefined)]))) 279 280(define-builtin-inliner current-error-port 281 (^[src args] 282 (match args 283 [() ($asm src `(,CURERR) '())] 284 [else (undefined)]))) 285 286(define-builtin-inliner dynamic-wind 287 (^[src args] 288 (match args 289 [(b t a) 290 (let ([at (make-lvar 'after)] 291 [bt (make-lvar 'before)] 292 [tt (make-lvar 'thunk)] 293 [r (make-lvar 'tmp)]) 294 (if (constant-lambda? a) 295 ;; when after thunk is dummy, we don't bother to call it. 296 ($let src 'let `(,at ,bt ,tt) `(,a ,b ,t) 297 ($seq 298 `(,($call ($*-src b) ($lref bt) '()) 299 ,($asm src `(,PUSH-HANDLERS) `(,($lref bt) ,($lref at))) 300 ,($call ($*-src t) ($lref tt) '())))) 301 ;; normal path 302 ($let src 'let `(,at ,bt ,tt) `(,a ,b ,t) 303 ($seq 304 `(,($call ($*-src b) ($lref bt) '()) 305 ,($asm src `(,PUSH-HANDLERS) `(,($lref bt) ,($lref at))) 306 ,($receive #f 0 1 (list r) 307 ($call ($*-src t) ($lref tt) '()) 308 ($seq 309 `(,($asm src `(,POP-HANDLERS) '()) 310 ,($call ($*-src a) ($lref at) '()) 311 ,($asm #f `(,TAIL-APPLY 2) 312 (list ($gref values.) ($lref r)))))) 313 )))))] 314 [_ (undefined)]))) 315 316