-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays layouts math math.order math.parser\r
-combinators combinators.short-circuit fry make sequences\r
-sequences.generalizations alien alien.private alien.strings\r
-alien.c-types alien.libraries classes.struct namespaces kernel\r
-strings libc locals quotations words cpu.architecture\r
-compiler.utilities compiler.tree compiler.cfg\r
-compiler.cfg.builder compiler.cfg.builder.alien.params\r
-compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks\r
-compiler.cfg.instructions compiler.cfg.stack-frame\r
-compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;\r
-FROM: compiler.errors => no-such-symbol no-such-library ;\r
-IN: compiler.cfg.builder.alien\r
-\r
-: unbox-parameters ( parameters -- vregs reps )\r
- [\r
- [ length iota <reversed> ] keep\r
- [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]\r
- 2 2 mnmap [ concat ] bi@\r
- ]\r
- [ length neg ##inc-d ] bi ;\r
-\r
-: prepare-struct-caller ( vregs reps return -- vregs' reps' )\r
- large-struct? [\r
- [ ^^prepare-struct-caller prefix ]\r
- [ int-rep struct-return-on-stack? 2array prefix ] bi*\r
- ] when ;\r
-\r
-: caller-parameter ( vreg rep on-stack? -- insn )\r
- [ dup reg-class-of reg-class-full? ] dip or\r
- [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]\r
- [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]\r
- if ;\r
-\r
-: (caller-parameters) ( vregs reps -- )\r
- ! Place ##store-stack-param instructions first. This ensures\r
- ! that no registers are used after the ##store-reg-param\r
- ! instructions.\r
- [ first2 caller-parameter ] 2map\r
- [ ##store-stack-param? ] partition [ % ] bi@ ;\r
-\r
-: caller-parameters ( params -- stack-size )\r
- [ abi>> ] [ parameters>> ] [ return>> ] tri\r
- '[ \r
- _ unbox-parameters\r
- _ prepare-struct-caller\r
- (caller-parameters)\r
- stack-params get\r
- ] with-param-regs ;\r
-\r
-: box-return* ( node -- )\r
- return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;\r
-\r
-GENERIC# dlsym-valid? 1 ( symbols dll -- ? )\r
-\r
-M: string dlsym-valid? dlsym ;\r
-\r
-M: array dlsym-valid? '[ _ dlsym ] any? ;\r
-\r
-: check-dlsym ( symbols dll -- )\r
- dup dll-valid? [\r
- dupd dlsym-valid?\r
- [ drop ] [ cfg get word>> no-such-symbol ] if\r
- ] [ dll-path cfg get word>> no-such-library drop ] if ;\r
-\r
-: decorated-symbol ( params -- symbols )\r
- [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi\r
- {\r
- [ drop ]\r
- [ "@" glue ]\r
- [ "@" glue "_" prepend ]\r
- [ "@" glue "@" prepend ]\r
- } 2cleave\r
- 4array ;\r
-\r
-: alien-invoke-dlsym ( params -- symbols dll )\r
- [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]\r
- [ library>> load-library ]\r
- bi 2dup check-dlsym ;\r
-\r
-: return-size ( c-type -- n )\r
- ! Amount of space we reserve for a return value.\r
- dup large-struct? [ heap-size ] [ drop 0 ] if ;\r
-\r
-: alien-node-height ( params -- )\r
- [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;\r
-\r
-: emit-alien-block ( node quot: ( params -- ) -- )\r
- '[\r
- make-kill-block\r
- params>>\r
- _ [ alien-node-height ] bi\r
- ] emit-trivial-block ; inline\r
-\r
-: <alien-stack-frame> ( stack-size return -- stack-frame )\r
- stack-frame new\r
- swap return-size >>return\r
- swap >>params\r
- t >>calls-vm? ;\r
-\r
-: emit-stack-frame ( stack-size params -- )\r
- [ return>> ] [ abi>> ] bi\r
- [ stack-cleanup ##cleanup ]\r
- [ drop <alien-stack-frame> ##stack-frame ] 3bi ;\r
-\r
-M: #alien-invoke emit-node\r
- [\r
- {\r
- [ caller-parameters ]\r
- [ alien-invoke-dlsym ##alien-invoke ]\r
- [ emit-stack-frame ]\r
- [ box-return* ]\r
- } cleave\r
- ] emit-alien-block ;\r
-\r
-M:: #alien-indirect emit-node ( node -- )\r
- node [\r
- D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src\r
- {\r
- [ caller-parameters ]\r
- [ drop src ##alien-indirect ]\r
- [ emit-stack-frame ]\r
- [ box-return* ]\r
- } cleave\r
- ] emit-alien-block ;\r
-\r
-M: #alien-assembly emit-node\r
- [\r
- {\r
- [ caller-parameters ]\r
- [ quot>> ##alien-assembly ]\r
- [ emit-stack-frame ]\r
- [ box-return* ]\r
- } cleave\r
- ] emit-alien-block ;\r
-\r
-: callee-parameter ( rep on-stack? -- dst insn )\r
- [ next-vreg dup ] 2dip\r
- [ dup reg-class-of reg-class-full? ] dip or\r
- [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]\r
- [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]\r
- if ;\r
-\r
-: prepare-struct-callee ( c-type -- vreg )\r
- large-struct?\r
- [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;\r
-\r
-: (callee-parameters) ( params -- vregs reps )\r
- [ flatten-parameter-type ] map\r
- [\r
- [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap\r
- concat [ ##load-reg-param? ] partition [ % ] bi@\r
- ] keep ;\r
-\r
-: box-parameters ( vregs reps params -- )\r
- ##begin-callback\r
- next-vreg next-vreg ##restore-context\r
- [\r
- next-vreg next-vreg ##save-context\r
- box-parameter\r
- 1 ##inc-d D 0 ##replace\r
- ] 3each ;\r
-\r
-: callee-parameters ( params -- stack-size )\r
- [ abi>> ] [ return>> ] [ parameters>> ] tri\r
- '[ \r
- _ prepare-struct-callee struct-return-area set\r
- _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi\r
- stack-params get\r
- struct-return-area get\r
- ] with-param-regs\r
- struct-return-area set ;\r
-\r
-: callback-stack-cleanup ( stack-size params -- )\r
- [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi\r
- "stack-cleanup" set-word-prop ;\r
-\r
-M: #alien-callback emit-node\r
- dup params>> xt>> dup\r
- [\r
- ##prologue\r
- [\r
- {\r
- [ callee-parameters ]\r
- [ quot>> ##alien-callback ]\r
- [\r
- return>> [ ##end-callback ] [\r
- [ D 0 ^^peek ] dip\r
- ##end-callback\r
- base-type unbox-return\r
- ] if-void\r
- ]\r
- [ callback-stack-cleanup ]\r
- } cleave\r
- ] emit-alien-block\r
- ##epilogue\r
- ##return\r
- ] with-cfg-builder ;\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays layouts math math.order math.parser
+combinators combinators.short-circuit fry make sequences
+sequences.generalizations alien alien.private alien.strings
+alien.c-types alien.libraries classes.struct namespaces kernel
+strings libc locals quotations words cpu.architecture
+compiler.utilities compiler.tree compiler.cfg
+compiler.cfg.builder compiler.cfg.builder.alien.params
+compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
+compiler.cfg.instructions compiler.cfg.stack-frame
+compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
+FROM: compiler.errors => no-such-symbol no-such-library ;
+IN: compiler.cfg.builder.alien
+
+: unbox-parameters ( parameters -- vregs reps )
+ [
+ [ length iota <reversed> ] keep
+ [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
+ 2 2 mnmap [ concat ] bi@
+ ]
+ [ length neg ##inc-d ] bi ;
+
+: prepare-struct-caller ( vregs reps return -- vregs' reps' )
+ large-struct? [
+ [ ^^prepare-struct-caller prefix ]
+ [ int-rep struct-return-on-stack? 2array prefix ] bi*
+ ] when ;
+
+: caller-parameter ( vreg rep on-stack? -- insn )
+ [ dup reg-class-of reg-class-full? ] dip or
+ [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
+ [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
+ if ;
+
+: (caller-parameters) ( vregs reps -- )
+ ! Place ##store-stack-param instructions first. This ensures
+ ! that no registers are used after the ##store-reg-param
+ ! instructions.
+ [ first2 caller-parameter ] 2map
+ [ ##store-stack-param? ] partition [ % ] bi@ ;
+
+: caller-parameters ( params -- stack-size )
+ [ abi>> ] [ parameters>> ] [ return>> ] tri
+ '[
+ _ unbox-parameters
+ _ prepare-struct-caller
+ (caller-parameters)
+ stack-params get
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
+
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
+
+M: string dlsym-valid? dlsym ;
+
+M: array dlsym-valid? '[ _ dlsym ] any? ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd dlsym-valid?
+ [ drop ] [ cfg get word>> no-such-symbol ] if
+ ] [ dll-path cfg get word>> no-such-library drop ] if ;
+
+: decorated-symbol ( params -- symbols )
+ [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
+ {
+ [ drop ]
+ [ "@" glue ]
+ [ "@" glue "_" prepend ]
+ [ "@" glue "@" prepend ]
+ } 2cleave
+ 4array ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
+ [ library>> load-library ]
+ bi 2dup check-dlsym ;
+
+: return-size ( c-type -- n )
+ ! Amount of space we reserve for a return value.
+ dup large-struct? [ heap-size ] [ drop 0 ] if ;
+
+: alien-node-height ( params -- )
+ [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
+: emit-alien-block ( node quot: ( params -- ) -- )
+ '[
+ make-kill-block
+ params>>
+ _ [ alien-node-height ] bi
+ ] emit-trivial-block ; inline
+
+: <alien-stack-frame> ( stack-size return -- stack-frame )
+ stack-frame new
+ swap return-size >>return
+ swap >>params
+ t >>calls-vm? ;
+
+: emit-stack-frame ( stack-size params -- )
+ [ return>> ] [ abi>> ] bi
+ [ stack-cleanup ##cleanup ]
+ [ drop <alien-stack-frame> ##stack-frame ] 3bi ;
+
+M: #alien-invoke emit-node
+ [
+ {
+ [ caller-parameters ]
+ [ alien-invoke-dlsym ##alien-invoke ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ } cleave
+ ] emit-alien-block ;
+
+M:: #alien-indirect emit-node ( node -- )
+ node [
+ D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
+ {
+ [ caller-parameters ]
+ [ drop src ##alien-indirect ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ } cleave
+ ] emit-alien-block ;
+
+M: #alien-assembly emit-node
+ [
+ {
+ [ caller-parameters ]
+ [ quot>> ##alien-assembly ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ } cleave
+ ] emit-alien-block ;
+
+: callee-parameter ( rep on-stack? -- dst insn )
+ [ next-vreg dup ] 2dip
+ [ dup reg-class-of reg-class-full? ] dip or
+ [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
+ [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
+ if ;
+
+: prepare-struct-callee ( c-type -- vreg )
+ large-struct?
+ [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
+
+: (callee-parameters) ( params -- vregs reps )
+ [ flatten-parameter-type ] map
+ [
+ [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
+ concat [ ##load-reg-param? ] partition [ % ] bi@
+ ]
+ [ [ keys ] map ]
+ bi ;
+
+: box-parameters ( vregs reps params -- )
+ ##begin-callback
+ next-vreg next-vreg ##restore-context
+ [
+ next-vreg next-vreg ##save-context
+ box-parameter
+ 1 ##inc-d D 0 ##replace
+ ] 3each ;
+
+: callee-parameters ( params -- stack-size )
+ [ abi>> ] [ return>> ] [ parameters>> ] tri
+ '[
+ _ prepare-struct-callee struct-return-area set
+ _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
+ stack-params get
+ struct-return-area get
+ ] with-param-regs
+ struct-return-area set ;
+
+: callback-stack-cleanup ( stack-size params -- )
+ [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
+ "stack-cleanup" set-word-prop ;
+
+M: #alien-callback emit-node
+ dup params>> xt>> dup
+ [
+ ##prologue
+ [
+ {
+ [ callee-parameters ]
+ [ quot>> ##alien-callback ]
+ [
+ return>> [ ##end-callback ] [
+ [ D 0 ^^peek ] dip
+ ##end-callback
+ base-type unbox-return
+ ] if-void
+ ]
+ [ callback-stack-cleanup ]
+ } cleave
+ ] emit-alien-block
+ ##epilogue
+ ##return
+ ] with-cfg-builder ;
projects / factor.git / commitdiff