! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes combinators compiler.units fry
-generalizations generic kernel locals namespaces quotations
-sequences sets slots words compiler.cfg.instructions
-compiler.cfg.instructions.syntax compiler.cfg.rpo ;
+USING: accessors assocs arrays classes combinators
+compiler.units fry generalizations generic kernel locals
+namespaces quotations sequences sets slots words
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.rpo ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
<PRIVATE
: slot-array-quot ( slots -- quot )
- [ [ drop f ] ] [
- [ reader-word 1quotation ] map
- dup length '[ _ cleave _ narray ]
- ] if-empty ;
+ [ reader-word 1quotation ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case ;
: define-defs-vreg-method ( insn -- )
[ \ defs-vreg create-method ]
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser accessors effects namespaces
-combinators splitting classes.parser lexer ;
+combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
SYMBOLS: def use temp literal constant ;
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
- [ dup '[ f _ boa , ] ] dip [ name>> ] map f <effect> define-declared ;
+ [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
+ [ name>> ] map f <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {
{
{ f [ [ rep>> ] ] }
{ scalar-rep [ [ rep>> scalar-rep-of ] ] }
- [ '[ _ nip ] ]
+ [ [ drop ] swap suffix ]
} case ;
: define-defs-vreg-rep-method ( insn -- )
bi define ;
: reps-getter-quot ( reps -- quot )
- [ rep>> rep-getter-quot ] map dup length '[ _ cleave _ narray ] ;
+ dup [ rep>> { f scalar-rep } memq? not ] all? [
+ [ rep>> ] map [ drop ] swap suffix
+ ] [
+ [ rep>> rep-getter-quot ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case
+ ] if ;
: define-uses-vreg-reps-method ( insn -- )
[ \ uses-vreg-reps create-method ]
{ constant [ [ constant>vn ] ] }
} case
] bi append
- ] map swap '[ _ cleave _ boa ] ;
+ ] map cleave>quot swap suffix \ boa suffix ;
: define->expr-method ( insn expr slot-specs -- )
[ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
: codegen-method-body ( class word -- quot )
[
"insn-slots" word-prop
- [ insn-slot-quot ] map
- ] dip
- '[ _ cleave _ execute ] ;
+ [ insn-slot-quot ] map cleave>quot
+ ] dip suffix ;
SYNTAX: CODEGEN:
scan-word [ \ generate-insn create-method-in ] keep scan-word