basis/compiler/cfg/builder/alien/params/params.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs cpu.architecture fry kernel layouts locals
   4 math math.order namespaces sequences vectors ;
   5 IN: compiler.cfg.builder.alien.params
   6
   7 SYMBOL: stack-params
   8
   9 GENERIC: alloc-stack-param ( rep -- n )
  10
  11 M: object alloc-stack-param ( rep -- n )
  12     stack-params get
  13     [ rep-size cell align stack-params +@ ] dip ;
  14
  15 M: float-rep alloc-stack-param ( rep -- n )
  16     stack-params get swap rep-size
  17     [ cell align stack-params +@ ] keep
  18     float-right-align-on-stack? [ + ] [ drop ] if ;
  19
  20 : ?dummy-stack-params ( rep -- )
  21     dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
  22
  23 : ?dummy-int-params ( rep -- )
  24     dummy-int-params? [
  25         rep-size cell /i 1 max
  26         [ int-regs get [ pop* ] unless-empty ] times
  27     ] [ drop ] if ;
  28
  29 : ?dummy-fp-params ( rep -- )
  30     drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
  31
  32 GENERIC: next-reg-param ( odd-register? rep -- reg )
  33
  34 M: int-rep next-reg-param
  35     [ nip ?dummy-stack-params ]
  36     [ nip ?dummy-fp-params ]
  37     [ drop [
  38         int-regs get last even?
  39         [ int-regs get pop* ] when
  40     ] when ]
  41     2tri int-regs get pop ;
  42
  43 M: object next-reg-param
  44     nip [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
  45     float-regs get pop ;
  46
  47 : reg-class-full? ( reg-class odd-register? -- ? )
  48     over length 1 = and [ dup delete-all ] when empty? ;
  49
  50 : init-reg-class ( abi reg-class -- )
  51     [ swap param-regs at <reversed> >vector ] keep set ;
  52
  53 : init-regs ( regs -- )
  54     [ <reversed> >vector swap set ] assoc-each ;
  55
  56 SYMBOLS: stack-values reg-values ;
  57
  58 :: next-parameter ( vreg rep on-stack? odd-register? -- )
  59     vreg rep on-stack?
  60     [ dup dup reg-class-of get odd-register? reg-class-full? ] dip or
  61     [ alloc-stack-param stack-values ] [ odd-register? swap next-reg-param reg-values ] if
  62     [ 3array ] dip get push ;
  63
  64 : next-return-reg ( rep -- reg ) reg-class-of get pop ;
  65
  66 : with-return-regs ( quot -- )
  67     '[ return-regs init-regs @ ] with-scope ; inline