src/HOL/Matrix/Compute_Oracle/am_interpreter.ML
changeset 46531 eff798e48efc
parent 42364 8c674b3b8e44
child 46534 55fea563fbee
equal deleted inserted replaced
46530:d5d14046686f 46531:eff798e48efc
    30 
    30 
    31 fun term_of_clos (CVar x) = Var x
    31 fun term_of_clos (CVar x) = Var x
    32   | term_of_clos (CConst c) = Const c
    32   | term_of_clos (CConst c) = Const c
    33   | term_of_clos (CApp (u, v)) = App (term_of_clos u, term_of_clos v)
    33   | term_of_clos (CApp (u, v)) = App (term_of_clos u, term_of_clos v)
    34   | term_of_clos (CAbs u) = Abs (term_of_clos u)
    34   | term_of_clos (CAbs u) = Abs (term_of_clos u)
    35   | term_of_clos (Closure (e, u)) = raise (Run "internal error: closure in normalized term found")
    35   | term_of_clos (Closure _) = raise (Run "internal error: closure in normalized term found")
    36   | term_of_clos CDummy = raise (Run "internal error: dummy in normalized term found")
    36   | term_of_clos CDummy = raise (Run "internal error: dummy in normalized term found")
    37 
    37 
    38 fun resolve_closure closures (CVar x) = (case nth closures x of CDummy => CVar x | r => r)
    38 fun resolve_closure closures (CVar x) = (case nth closures x of CDummy => CVar x | r => r)
    39   | resolve_closure closures (CConst c) = CConst c
    39   | resolve_closure closures (CConst c) = CConst c
    40   | resolve_closure closures (CApp (u, v)) = CApp (resolve_closure closures u, resolve_closure closures v)
    40   | resolve_closure closures (CApp (u, v)) = CApp (resolve_closure closures u, resolve_closure closures v)
    59     end
    59     end
    60 
    60 
    61 fun strip_closure args (CApp (a,b)) = strip_closure (b::args) a
    61 fun strip_closure args (CApp (a,b)) = strip_closure (b::args) a
    62   | strip_closure args x = (x, args)
    62   | strip_closure args x = (x, args)
    63 
    63 
    64 fun len_head_of_closure n (CApp (a,b)) = len_head_of_closure (n+1) a
    64 fun len_head_of_closure n (CApp (a, _)) = len_head_of_closure (n+1) a
    65   | len_head_of_closure n x = (n, x)
    65   | len_head_of_closure n x = (n, x)
    66 
    66 
    67 
    67 
    68 (* earlier occurrence of PVar corresponds to higher de Bruijn index *)
    68 (* earlier occurrence of PVar corresponds to higher de Bruijn index *)
    69 fun pattern_match args PVar clos = SOME (clos::args)
    69 fun pattern_match args PVar clos = SOME (clos::args)
    93   | pattern_key _ = raise (Compile "pattern reduces to variable")
    93   | pattern_key _ = raise (Compile "pattern reduces to variable")
    94 
    94 
    95 (*Returns true iff at most 0 .. (free-1) occur unbound. therefore
    95 (*Returns true iff at most 0 .. (free-1) occur unbound. therefore
    96   check_freevars 0 t iff t is closed*)
    96   check_freevars 0 t iff t is closed*)
    97 fun check_freevars free (Var x) = x < free
    97 fun check_freevars free (Var x) = x < free
    98   | check_freevars free (Const c) = true
    98   | check_freevars free (Const _) = true
    99   | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v
    99   | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v
   100   | check_freevars free (Abs m) = check_freevars (free+1) m
   100   | check_freevars free (Abs m) = check_freevars (free+1) m
   101   | check_freevars free (Computed t) = check_freevars free t
   101   | check_freevars free (Computed t) = check_freevars free t
   102 
   102 
   103 fun compile cache_patterns const_arity eqs =
   103 fun compile _ _ eqs =
   104     let
   104     let
   105         fun check p r = if check_freevars p r then () else raise Compile ("unbound variables in rule") 
   105         fun check p r = if check_freevars p r then () else raise Compile ("unbound variables in rule") 
   106         fun check_guard p (Guard (a,b)) = (check p a; check p b) 
   106         fun check_guard p (Guard (a,b)) = (check p a; check p b) 
   107         fun clos_of_guard (Guard (a,b)) = (clos_of_term a, clos_of_term b)
   107         fun clos_of_guard (Guard (a,b)) = (clos_of_term a, clos_of_term b)
   108         val eqs = map (fn (guards, p, r) => let val pcount = count_patternvars p val _ = map (check_guard pcount) (guards) val _ = check pcount r in 
   108         val eqs = map (fn (guards, p, r) => let val pcount = count_patternvars p val _ = map (check_guard pcount) (guards) val _ = check pcount r in 
   159       | _ => NONE
   159       | _ => NONE
   160 
   160 
   161 and weak_reduce (false, prog, stack, Closure (e, CApp (a, b))) = Continue (false, prog, SAppL (Closure (e, b), stack), Closure (e, a))
   161 and weak_reduce (false, prog, stack, Closure (e, CApp (a, b))) = Continue (false, prog, SAppL (Closure (e, b), stack), Closure (e, a))
   162   | weak_reduce (false, prog, SAppL (b, stack), Closure (e, CAbs m)) = Continue (false, prog, stack, Closure (b::e, m))
   162   | weak_reduce (false, prog, SAppL (b, stack), Closure (e, CAbs m)) = Continue (false, prog, stack, Closure (b::e, m))
   163   | weak_reduce (false, prog, stack, Closure (e, CVar n)) = Continue (false, prog, stack, case nth e n of CDummy => CVar n | r => r)
   163   | weak_reduce (false, prog, stack, Closure (e, CVar n)) = Continue (false, prog, stack, case nth e n of CDummy => CVar n | r => r)
   164   | weak_reduce (false, prog, stack, Closure (e, c as CConst _)) = Continue (false, prog, stack, c)
   164   | weak_reduce (false, prog, stack, Closure (_, c as CConst _)) = Continue (false, prog, stack, c)
   165   | weak_reduce (false, prog, stack, clos) =
   165   | weak_reduce (false, prog, stack, clos) =
   166     (case match_closure prog clos of
   166     (case match_closure prog clos of
   167          NONE => Continue (true, prog, stack, clos)
   167          NONE => Continue (true, prog, stack, clos)
   168        | SOME r => Continue (false, prog, stack, r))
   168        | SOME r => Continue (false, prog, stack, r))
   169   | weak_reduce (true, prog, SAppR (a, stack), b) = Continue (false, prog, stack, CApp (a,b))
   169   | weak_reduce (true, prog, SAppR (a, stack), b) = Continue (false, prog, stack, CApp (a,b))
   170   | weak_reduce (true, prog, s as (SAppL (b, stack)), a) = Continue (false, prog, SAppR (a, stack), b)
   170   | weak_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
   171   | weak_reduce (true, prog, stack, c) = Stop (stack, c)
   171   | weak_reduce (true, prog, stack, c) = Stop (stack, c)
   172 
   172 
   173 and strong_reduce (false, prog, stack, Closure (e, CAbs m)) =
   173 and strong_reduce (false, prog, stack, Closure (e, CAbs m)) =
   174     (let
   174     (let
   175          val (stack', wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure (CDummy::e, m))
   175          val (stack', wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure (CDummy::e, m))
   176      in
   176      in
   177          case stack' of
   177          case stack' of
   178              SEmpty => Continue (false, prog, SAbs stack, wnf)
   178              SEmpty => Continue (false, prog, SAbs stack, wnf)
   179            | _ => raise (Run "internal error in strong: weak failed")
   179            | _ => raise (Run "internal error in strong: weak failed")
   180      end handle InterruptedExecution state => raise InterruptedExecution (stack, resolve state))
   180      end handle InterruptedExecution state => raise InterruptedExecution (stack, resolve state))
   181   | strong_reduce (false, prog, stack, clos as (CApp (u, v))) = Continue (false, prog, SAppL (v, stack), u)
   181   | strong_reduce (false, prog, stack, CApp (u, v)) = Continue (false, prog, SAppL (v, stack), u)
   182   | strong_reduce (false, prog, stack, clos) = Continue (true, prog, stack, clos)
   182   | strong_reduce (false, prog, stack, clos) = Continue (true, prog, stack, clos)
   183   | strong_reduce (true, prog, SAbs stack, m) = Continue (false, prog, stack, CAbs m)
   183   | strong_reduce (true, prog, SAbs stack, m) = Continue (false, prog, stack, CAbs m)
   184   | strong_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
   184   | strong_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
   185   | strong_reduce (true, prog, SAppR (a, stack), b) = Continue (true, prog, stack, CApp (a, b))
   185   | strong_reduce (true, prog, SAppR (a, stack), b) = Continue (true, prog, stack, CApp (a, b))
   186   | strong_reduce (true, prog, stack, clos) = Stop (stack, clos)
   186   | strong_reduce (true, prog, stack, clos) = Stop (stack, clos)
   206                             (SEmpty, snf) => term_of_clos snf
   206                             (SEmpty, snf) => term_of_clos snf
   207                           | _ => raise (Run "internal error in run: strong failed"))
   207                           | _ => raise (Run "internal error in run: strong failed"))
   208            | _ => raise (Run "internal error in run: weak failed")
   208            | _ => raise (Run "internal error in run: weak failed")
   209      end handle InterruptedExecution state => term_of_clos (resolve state))
   209      end handle InterruptedExecution state => term_of_clos (resolve state))
   210 
   210 
   211 fun discard p = ()
   211 fun discard _ = ()
   212 
   212 
   213 end
   213 end