rowl1-matching.rlc

;
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
; $Id: rowl1-matching.rlc 2013-03-05 06:57:44 nineties $
;

(import "rlvm-compile")
(import "rowl1-types")

(compile `object `(

(import "rowl1-util")
(import "rowl1-node")
(import "rowl1-assemble")
(import "rowl1-compile")
(import "rowl1-error")

; pattern matrix (((p11 p12 .. ) e1 g1) ((p21 p22 ..) e2 g2) ..)

(var dontcareP (to_sym "%DontCare"))
(var ellipsisP (to_sym "%Ellipsis"))
(var varP      (to_sym "%Var"))
(var domP      (to_sym "%Domain"))

(extern object current_loc)

(fun trace_func (msg val) (
    (debugs msg)
    (debugpf val)
    (return val)
    ))

(fun trace (asm msg) (
    (put_push asm (string msg))
    (compile_simple_call asm 2 trace_func)
    ))

(fun compile_matching_unwrap (loc obj def) (
    (if (== (node_type def) @DelegateFunctionE)
        (= def (field_get def 2))
        )
    (return (compile_matching loc obj def))
    ))

(export fun compile_matching (loc obj def) (
    (if (! (is_function def))
        (throw (type_error loc (string "function") obj))
        )

    (var cache (field_get def 1))
    (if cache (return cache))

    (var asm (make_assembler))

    (if (!= (node_type def) @DelegateFunctionE)
        (compile_matching_single_function asm loc obj def)
        (do
            (var fun (field_get def 2))
            (var delegatee (field_get def 3))
            (compile_matching_single_function asm loc obj fun)
            (while delegatee (do
                (var disp (car delegatee))
                (var failed (fresh_label asm))

                (put_push asm disp)
                (put_car asm)
                (put_push asm obj)
                (put_push asm current_loc)
                (compile_simple_call asm 3 compile_matching_unwrap)
                (put_jccall asm)
                (put_dup asm)
                (put_undef asm)
                (put_if_eq asm failed)
                (put_ireturn asm)
                (set_label asm failed)
                (put_drop asm)
    
                (= delegatee (cdr delegatee))
                ))
        ))

    (put_undef asm)
    (put_ireturn asm)

    (var code (get_code asm))
    (field_set def 1 code) ; caching
    (return code)
    ))

(fun compile_matching_single_function (asm loc obj def) (
    (if (! (is_function def))
        (throw (type_error loc (string "function") obj))
        )

    ; here, `def' has form of Function{ ... } of BoundFunction{ ... }

    ; construct pattern matrix 
    (var mat (construct_pattern_matrix def))

    (var args 0)
    (var idx (- (list_len (caar mat)) 1))
    (while (> idx 0) (do
        (decr idx)
        (= args (cons (make_arg idx) args))
        ))
    (= args (cons (get_arity) args))

    (compile_matching_main asm args mat)
    ))

(fun construct_pattern_matrix (def) (
    ; compute maximum arity
    (var len (max_arity def))
    (return (construct_pattern_matrix_sub len def 0))
    ))

(fun construct_pattern_matrix_sub (len def tl) (
    (if (== (node_type def) @FunctionE)
        (return (cons (construct_row len def) tl))
        )
    (if (== (node_type def) @BoundFunctionE) (do
        (var fun1 (field_get def 2))
        (var fun2 (field_get def 3))
        (= tl (construct_pattern_matrix_sub len fun2 tl))
        (return (construct_pattern_matrix_sub len fun1 tl))
        ))
    (throw (string "BUG: construct_pattern_matrix_sub"))
    ))

(fun max_arity (def) (
    (if (== (node_type def) @FunctionE)
        (return (list_len (field_get def 2)))
        )
    (if (== (node_type def) @BoundFunctionE) (do
        (var len1 (max_arity (field_get def 2)))
        (var len2 (max_arity (field_get def 3)))
        (if (< len1 len2)
            (return len2)
            (return len1)
            )
        ))
    (throw (string "BUG: max_arity"))
    ))

(fun construct_row (len def) (
    (var args (field_get def 2))
    (var code (field_get def 3))
    (var guard (field_get def 4))
    (= args (setup_args len args))
    (return (list3 args code guard))
    ))

(fun setup_args (len args) (
    (if (== len 0) (return 0))
    (if (! args) (return (diag_list len dontcareP)))
    (return (cons (setup_pat (car args)) (setup_args (- len 1) (cdr args))))
    ))

(fun setup_pat (pat) (
    (if (== pat DontCare)
        (return dontcareP)
        )
    (if (is_special pat)
        (return pat)
        )
    (if (is_symbol pat)
        (return varP)
        )
    (var hd (node_bhead pat))
    (if (|| (== hd BInt) (== hd BString))
        (return pat)
        )
    (if (== hd Domain) (do
        (var lhs (setup_pat (node_arg pat 0)))
        (var dom (node_arg pat 1))
        (if (is_symbol dom)
            (return (make_object2 domP lhs dom))
            (return (setup_pat dom))
            )
        ))
    (if (== hd Ellipsis)
        (return ellipsisP)
        )
    (if (== hd List)
        (return (setup_pat_list pat))
        )
    (if (== hd Tuple)
        (return (setup_pat_tuple pat))
        )
    (if (== hd Quote)
        (return (node_arg pat 0))
        )
    (if (== hd QuasiQuote)
        (return (qquote_pat (node_arg pat 0) 0))
        )
    (= pat (copy pat))
    (for i 0 (node_size pat)
        (node_arg_set pat i (setup_pat (node_arg pat i)))
        )
    (return pat)
    ))

(fun setup_pat_list (list) (
    (if (! list) (return 0))
    (return (cons (setup_pat (car list)) (setup_pat_list (cdr list))))
    ))

(fun setup_pat_tuple (t) (
    (var n (seq_size t))
    (var p (allocate_tuple n))
    (for i 0 n (do
        (array_set object p i (setup_pat (array_get object t i)))
        ))
    (return p)
    ))

(fun qquote_pat_list (pat level) (
    (var ret 0)
    (while pat (do
        (= ret (cons (qquote_pat (car pat) level) ret))
        (= pat (cdr pat))
        ))
    (return (list_reverse ret))
    ))

(fun qquote_pat_tuple (pat level) (
    (var n (seq_size pat))
    (var p (allocate_tuple n))
    (for i 0 n (do
        (array_set object p i (qquote_pat (array_get object pat i) level))
        ))
    (return p)
    ))

(fun qquote_pat (pat level) (
    (var hd (node_bhead pat))
    (if (|| (== hd BSymbol) (|| (== hd BInt) (== hd BString)))
        (return pat)
        )
    (if (== hd List)
        (return (qquote_pat_list pat level))
        )
    (if (== hd Tuple)
        (return (qquote_pat_tuple pat level))
        )
    (if (== hd Unquote) (do
        (if (== level 0)
            (return (setup_pat (node_arg pat 0)))
            (return (qquote_pat (node_arg pat 0) (- level 1)))
            )
        )
    (if (== hd QuasiQuote)
        (+= level 1)
        ))
    (= pat (copy pat))
    (for i 0 (node_size pat)
        (node_arg_set pat i (qquote_pat (node_arg pat i) level))
        )
    (return pat)
    ))

(fun compile_matching_main (asm args pats) (
    (if (== (caar pats) 0) (do
        (label compile_matching_main_loop)
        (var func (car pats))
        (var code (list_at func 1))
        (var guard (list_at func 2))

        (if guard
            (do
                (var guard_failed (fresh_label asm))
                (put_code asm guard)
                (put_if_false asm guard_failed)
                (put_push asm code)
                (put_jjump asm)
                (set_label asm guard_failed)
                (if (cdr pats) (do
                    (= pats (cdr pats))
                    (goto compile_matching_main_loop)
                    ))
            )
            (do
                (put_push asm code)
                (put_jjump asm)
            ))
        return
        ))
    (var x (split_pattern_matrix pats)) ; (single . remain)
    (compile_matching_single asm args (car x))
    (if (cdr x)
        (compile_matching_main asm args (cdr x))
        )
    ))

(fun compile_matching_single (asm args pats) (
    (var p (caaar pats))
    (if (== p dontcareP) (do
        (= pats (shift_pat pats))
        (compile_matching_main asm (cdr args) pats)
        return
        ))
    (if (== p varP) (do
        (= pats (shift_pat pats))
        (compile_matching_main asm (cdr args) pats)
        return
        ))
    (if (== p ellipsisP) (do
        (= pats (shift_pat pats))
        (compile_matching_main asm args pats)
        return
        ))
    (if (is_special p) (do
        (var check_failed (fresh_label asm))
        (compile_operand asm (car args) @C_NIL)
        (put_imm_int16 asm p)
        (put_if_ne asm check_failed)
        (= pats (shift_pat pats))
        (compile_matching_main asm (cdr args) pats)
        (set_label asm check_failed)
        return
        ))
    (var hd (node_bhead p))
    (if (== hd BSymbol) (do
        (var check_failed (fresh_label asm))
        (compile_operand asm (car args) @C_NIL)
        (put_push asm p)
        (put_if_ne asm check_failed)
        (= pats (shift_pat pats))
        (compile_matching_main asm (cdr args) pats)
        (set_label asm check_failed)
        return
        ))
    (if (== hd BInt) (do
        (var check_failed (fresh_label asm))
        (compile_operand asm (car args) @C_NIL)
        (put_check_int asm check_failed)
        (compile_matching_intlit asm args pats)
        (set_label asm check_failed)
        return
        ))
    (if (== hd BString) (do
        (var check_failed (fresh_label asm))
        (compile_operand asm (car args) @C_NIL)
        (put_check_string asm check_failed)
        (compile_operand asm (car args) @C_NIL)
        (compile_matching_string_lit asm p check_failed)
        (= pats (shift_pat pats))
        (compile_matching_main asm (cdr args) pats)
        (set_label asm check_failed)
        return
        ))
    (if (== hd domP) (do
        (var pat (node_arg_symbol p 1))
        (var check_failed (fresh_label asm))
        (compile_operand asm (car args) @C_NIL)
        (compile_head_check asm pat check_failed)
        (= pats (shift_pat pats))
        (compile_matching_main asm (cdr args) pats)
        (set_label asm check_failed)
        return
        ))
    (if (== hd List) (do
        (if (is_ellipsis_list p)
            (do
                (var len (- (list_len p) 1))
                (var check_failed (fresh_label asm))
                (compile_operand asm (car args) @C_NIL)
                (put_check_list2 asm check_failed len)

                ; flatten list pattern
                (= pats (expand_list_pat pats))

                ; add list elements to args
                (var ls (car args))
                (= args (cdr args))
                (while (> len 0) (do
                    (decr len)
                    (= args (cons (make_list_at ls len) args))
                    ))

                (compile_matching_main asm args pats)
                (set_label asm check_failed)
            )
            (do
                (var len (list_len p))
                (var check_failed (fresh_label asm))
                (compile_operand asm (car args) @C_NIL)
                (put_check_list asm check_failed len)

                ; flatten list pattern
                (= pats (expand_list_pat pats))

                ; add list elements to args
                (var ls (car args))
                (= args (cdr args))
                (while (> len 0) (do
                    (decr len)
                    (= args (cons (make_list_at ls len) args))
                    ))

                (compile_matching_main asm args pats)
                (set_label asm check_failed)
            ))
        return
        ))

    (var check_failed (fresh_label asm))
    (var size (node_size p))
    (compile_operand asm (car args) @C_NIL)
    (compile_head_check asm hd check_failed)

    (if (is_ellipsis_node p size)
        (if (> size 1) (do
            (compile_operand asm (car args) @C_NIL)
            (compile_simple_call asm 1 node_size)
            (put_imm_int asm (- size 1))
            (put_if_lt asm check_failed)
            ))
        (do
            (compile_operand asm (car args) @C_NIL)
            (compile_simple_call asm 1 node_size)
            (put_imm_int asm size)
            (put_if_ne asm check_failed)
        ))

    ; flatten expression pattern
    (= pats (expand_composite_pat pats))
    ; add arguments to args
    (var expr (car args))
    (= args (cdr args))
    (rfor i 0 size
        (= args (cons (make_object_at p expr i) args))
        )
    (compile_matching_main asm args pats)
    (set_label asm check_failed)
    ))

(fun is_ellipsis_list (pats) (
    (while pats (do
        (if (== (car pats) ellipsisP) (do
            (if (cdr pats) (throw (exception current_loc (string "ellipsis-pattern must be placed at the end of the list"))))
            (return @TRUE)
            ))
        (= pats (cdr pats))
        ))
    (return @FALSE)
    ))

(fun is_ellipsis_node (expr size) (
    (if (== size 0) (return @FALSE))
    (if (== (node_arg expr (- size 1)) ellipsisP)
        (return @TRUE)
        (return @FALSE)
        )
    ))

(fun compile_head_check (asm ty exit_lbl) (
    (if (== ty BInt) (do
        (put_check_int asm exit_lbl)
        return
        ))
    (if (== ty BString) (do
        (put_check_string asm exit_lbl)
        return
        ))
    (if (is_hidden_sym ty)
        (do
            (put_imm_int32 asm node_bhead)
            (put_dcall asm 4)
        )
        (do
            (put_imm_int32 asm node_head)
            (put_dcall asm 4)
        ))


    (put_push asm ty)
    (put_if_ne asm exit_lbl)
    ))

(fun compile_matching_intlit (asm args pats) (
    (= pats (sort_int_pat pats))
    (var r (scan_int_cases pats))
    (var continues (unbox (car r)))
    (var cases (cdr r))

    (if continues
        (compile_matching_intlit_tswitch asm args pats cases)
        (compile_matching_intlit_lswitch asm args pats cases)
        )
    ))

(fun compile_matching_intlit_tswitch (asm args pats cases) (
    (var ncases (list_len cases))
    (var end_lbl (fresh_label asm))
    (var case_lbls (array int ncases))
    (for i 0 ncases
        (array_set int case_lbls i (fresh_label asm))
        )

    (compile_operand asm (car args) @C_NIL)

    ; unbox
    (put_unbox asm)

    (put_tswitch asm ncases)
    (for i 0 ncases
        (emit_tswitch_label asm (array_get int case_lbls i))
        )
    (emit_tswitch_label asm end_lbl)
    (for i 0 ncases (do
        (var n (unbox (cdar cases)))
        (var r (list_split pats n))
        (= pats (cdr r))
        (set_label asm (array_get int case_lbls i))
        (compile_matching_main asm (cdr args) (shift_pat (car r)))
        (= cases (cdr cases))
        ))
    (set_label asm end_lbl)
    ))

(fun compile_matching_intlit_lswitch (asm args pats cases) (
    (var ncases 0)
    (var max (caar cases))
    (var cases_copy cases)
    (while cases_copy (do
        (incr ncases)
        (if (< max (caar cases_copy))
            (= max (caar cases_copy))
            )
        (= cases_copy (cdr cases_copy))
        ))
    (= max (+ (unbox max) 1))

    (var end_lbl (fresh_label asm))
    (var case_lbls (array int ncases))
    (for i 0 ncases
        (array_set int case_lbls i (fresh_label asm))
        )

    (compile_operand asm (car args) @C_NIL)

    ; unbox arg
    (put_unbox asm)

    (put_lswitch asm max)
    (= cases_copy cases)
    (for i 0 ncases (do
        (emit_int asm (unbox (caar cases_copy)))
        (emit_lswitch_label asm (array_get int case_lbls i))
        (= cases_copy (cdr cases_copy))
        ))
    (emit_int asm max)
    (emit_lswitch_label asm end_lbl)
    (for i 0 ncases (do
        (var n (unbox (cdar cases)))
        (var r (list_split pats n))
        (= pats (cdr r))
        (set_label asm (array_get int case_lbls i))
        (compile_matching_main asm (cdr args) (shift_pat (car r)))
        (= cases (cdr cases))
        ))
    (set_label asm end_lbl)
    ))

(fun sort_int_pat (pats) (
    (var ret 0)
    (while pats (do
        (var p (car pats))
        (= pats (cdr pats))
        (= ret (insert_int_pat p ret))
        ))
    (return ret)
    ))

(fun insert_int_pat (p ls) (
    (if (! ls) (return (cons p 0)))
    (var a (caar p))
    (var b (caaar ls))
    (if (< a b)
        (return (cons p ls))
        (return (cons (car ls) (insert_int_pat p (cdr ls))))
        )
    ))

(fun scan_int_cases (pats) (
    (var p (caaar pats))
    (var ret 0)
    (var num 0)
    (var continues @FALSE)
    (if (== (unbox p) 0) (do
        (= continues @TRUE)
        ))
    (while pats (do
        (if (== p (caaar pats))
            (do
                (incr num)
                (= pats (cdr pats))
            )
            (do
                (if (!= (+ p 2) (caaar pats))
                    (= continues @FALSE)
                    )
                (= ret (cons (cons p (box num)) ret))
                (= p (caaar pats))
                (= num 1)
                (= pats (cdr pats))
            ))
        ))
    (= ret (cons (cons p (box num)) ret))
    (return (cons (box continues) (list_reverse ret)))
    ))

(fun collect_same_int_pat (pats) (
    (var n 1)
    (var orig pats)
    (var val (caaar pats))
    (= pats (cdr pats))
    (while (&& pats (== (caaar pats) val)) (do
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun compile_matching_string_lit (asm str exit_lbl) (
    (put_push asm str)
    (compile_simple_call asm 2 streq)
    (put_if_zero asm exit_lbl)
    ))

(fun split_pattern_matrix (pats) (
    (var p (caaar pats))
    (if (== p varP) (return (split_any pats)))
    (if (is_special p) (return (split_special p pats)))
    (var hd (node_bhead p))
    (if (== hd BInt) (return (split_int_pat pats)))
    (if (== hd BString) (return (split_string_pat pats)))
    (if (== hd domP) (return (split_head_pat (node_arg_symbol p 1) pats)))
    (if (== hd BSymbol) (return (split_symbol_pat 0 pats)))
    (if (== hd List) (return (split_list_pat pats)))
    (return (split_composite_pat pats))
    ))

(fun split_any (pats) (
    (var n 1)
    (var orig pats)
    (= pats (cdr pats))
    (while (&& pats (|| (== (caaar pats) dontcareP) (== (caaar pats) varP))) (do
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun split_special (v pats) (
    (var n 1)
    (var orig pats)
    (= pats (cdr pats))
    (while (&& pats (== v (caaar pats))) (do
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun split_int_pat (pats) (
    (var n 1)
    (var orig pats)
    (= pats (cdr pats))
    (while (&& pats (== (node_type (caaar pats)) @IntE)) (do
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun split_string_pat (pats) (
    (var n 1)
    (var orig pats)
    (var str (caaar pats))
    (= pats (cdr pats))
    (while pats (do
        (var nd (caaar pats))
        (if (|| (!= (node_type nd) @StringE) (! (streq str nd))) break)
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun head_check (hd node) (
    (if (&& (== (node_bhead node) domP) (== (node_arg_symbol node 1) hd))
        (return @TRUE)
        (return @FALSE)
        )
    ))

(fun split_head_pat (hd pats) (
    (var n 1)
    (var orig pats)
    (= pats (cdr pats))
    (while (&& pats (head_check hd (caaar pats))) (do
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun same_symbol_pat (sym node) (
    (var hd (node_bhead node))
    (if (&& (== hd BSymbol) (== node sym))
        (return @TRUE)
        (return @FALSE)
        )
    ))

(fun split_symbol_pat (sym pats) (
    (var n 1)
    (var orig pats)
    (= pats (cdr pats))
    (while (&& pats (same_symbol_pat sym (caaar pats))) (do
        (= pats (cdr pats))
        (incr n)
        ))
    (return (list_split orig n))
    ))

(fun split_list_pat (pats) (
    (= pats (sort_list_pat pats))
    (var n 1)
    (var orig pats)
    (var p (caaar pats))
    (var len (list_len (caaar pats)))
    (= pats (cdr pats))
    (if (is_ellipsis_list p)
        (do
            (while pats (do
                (var nd (caaar pats))
                (if (|| (!= (node_bhead nd) List)
                    (|| (!= (list_len nd) len)
                        (! (is_ellipsis_list nd))))
                    break)
                (= pats (cdr pats))
                (incr n)
                ))
            (return (list_split orig n))
        )
        (do
            (while pats (do
                (var nd (caaar pats))
                (if (|| (!= (node_bhead nd) List)
                    (|| (!= (list_len nd) len)
                        (is_ellipsis_list nd)))
                    break)
                (= pats (cdr pats))
                (incr n)
                ))
            (return (list_split orig n))
        ))
    ))

(fun sort_list_pat (pats) (
    (var ret 0)
    (while pats (do
        (var p (car pats))
        (= pats (cdr pats))
        (= ret (insert_list_pat p ret))
        ))
    (return ret)
    ))

(fun insert_list_pat (p pats) (
    (if (! pats) (return (cons p 0)))
    (var a (caar p))
    (var b (caaar pats))
    (if (!= (node_bhead a) List) (return (cons (car pats) (insert_list_pat p (cdr pats)))))
    (if (!= (node_bhead b) List) (return (cons p pats)))
    (var alen (list_len a))
    (var blen (list_len b))
    (if (<= alen blen)
        (return (cons p pats))
        (return (cons (car pats) (insert_list_pat p (cdr pats))))
        )
    ))

(fun split_composite_pat (pats) (
    (var n 1)
    (var orig pats)
    (var p (caaar pats))
    (var hd (node_bhead p))
    (var size (node_size p))
    (= pats (cdr pats))
    (if (is_ellipsis_node p size)
        (do
            (while pats (do
                (var nd (caaar pats))
                (if (|| (!= (node_bhead nd) hd)
                    (|| (!= (node_size nd) size)
                        (! (is_ellipsis_node nd size))))
                    break)
                (= pats (cdr pats))
                (incr n)
                ))
            (return (list_split orig n))
        )
        (do
            (while pats (do
                (var nd (caaar pats))
                (if (|| (!= (node_bhead nd) hd)
                    (|| (!= (node_size nd) size)
                        (is_ellipsis_node nd size)))
                    break)
                (= pats (cdr pats))
                (incr n)
                ))
            (return (list_split orig n))
        ))
    (return (list_split orig n))
    ))

(fun shift_pat (pats) (
    (var list pats)
    (while list (do
        (setcar list (cons (cdaar list) (cdar list)))
        (= list (cdr list))
        ))
    (return pats)
    ))

(fun expand_list_pat (pats) (
    (if (== pats 0) (return 0))
    (return (cons (cons (list_append (caaar pats) (cdaar pats)) (cdar pats))
        (expand_list_pat (cdr pats))))
    ))

(extern fun tuple_to_list)
(fun expand_tuple_pat (pats) (
    (if (== pats 0) (return 0))
    (return (cons (cons (list_append (tuple_to_list (caaar pats)) (cdaar pats)) (cdar pats))
        (expand_list_pat (cdr pats))))
    ))

(fun expand_composite_pat (pats) (
    (if (== pats 0) (return 0))
    (return (cons (cons (list_append (node_args (caaar pats)) (cdaar pats)) (cdar pats))
        (expand_composite_pat (cdr pats))))
    ))

    ))