1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
{-# LANGUAGE TupleSections #-}
module Code where
import Control.Monad.Trans.State.Lazy (StateT)
import qualified Data.Map as M
import IR (Id(..), StrTable)
import Operators (Ops)
import Parser (PAST)
import System.Console.Haskeline (InputT)
data Datum
= Atom Int -- unifies a symbolic constant
| Number Int -- unifies a numeric constant
| Struct Id -- unifies a structure with arity
| VoidRef -- unifies with anything
| LocalRef Int -- code-local variable idx (should never occur on heap)
| HeapRef Int -- something further on the heap
deriving (Show, Eq, Ord)
data Instr
= U Datum -- unify/resolve something
| Invoke Builtin -- give control to a builtin (invoked from head)
| Done -- all done, can return
| Cut -- remove choicepoints of the current goal
| Choices [[Code]] -- split off several possibilities (push choicepoints)
deriving (Show)
type Code = [Instr]
type Defs = M.Map Id [Code]
data Heap =
Heap Int (M.Map Int Datum)
deriving (Show)
emptyHeap = Heap 1 M.empty
type Scope = M.Map Int Int
emptyScope :: Scope
emptyScope = M.empty
data Cho =
Cho
{ _hed :: Code -- head pointer
, _hvar :: Scope -- variables unified in head (so far)
, _gol :: Code -- goal pointer
, _gvar :: Scope -- variables unified in the goal
, _unis :: Int -- items left to unify
, _retcut :: Bool -- cut after this goal succeeds
, _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
, _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag
, _cut :: [Cho] -- snapshot of choicepoints before entering
}
deriving (Show)
data Interp =
Interp
{ _defs :: Defs -- global definitions for lookup
, _cur :: Cho -- the choice that is being evaluated right now
, _cho :: [Cho] -- remaining choice points
, _ops :: Ops -- currently defined operators
, _opstash :: [Ops] -- saved operators
, _macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query)
, _strtable :: StrTable -- string table
, _cmdq :: [(Bool, PAST)] -- isQuery, lexemes
}
deriving (Show)
type PrlgEnv = StateT Interp (InputT IO)
type InterpFn = PrlgEnv (Maybe (Either String Bool))
data Builtin =
Builtin InterpFn
instance Show Builtin where
show _ = "Builtin _"
data Dereferenced
= FreeRef Int
| BoundRef Int Datum
| NoRef
deriving (Show, Eq)
-- TRICKY: HeapRefs alone must not form a cycle other than the FreeRef case.
derefHeap :: Heap -> Int -> Dereferenced
derefHeap h@(Heap _ hmap) x =
case hmap M.!? x of
Just (HeapRef x') ->
if x == x'
then FreeRef x'
else derefHeap h x'
Just x' -> BoundRef x x'
_ -> NoRef
writeHeap :: Int -> Datum -> Heap -> Heap
writeHeap addr x (Heap nxt m) = Heap nxt (M.adjust (const x) addr m)
newHeapVar :: Heap -> (Heap, Int)
newHeapVar heap = head <$> newHeapVars 1 heap
newHeapVars :: Int -> Heap -> (Heap, [Int])
newHeapVars n (Heap nxt m) =
let addrs = [nxt + i - 1 | i <- [1 .. n]]
in ( Heap (nxt + n) $
foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs]
, addrs)
withNewHeapStruct :: Int -> Datum -> Heap -> ([Datum] -> Heap -> a) -> a
withNewHeapStruct addr s@(Struct Id {arity = arity}) heap cont =
let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
m'' = M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ m'
in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
heapStruct ::
Monad m
=> (Datum -> m a)
-> (Datum -> [a] -> m a)
-> (Datum -> Int -> m a)
-> Heap
-> Int
-> m a
heapStruct atom struct rec (Heap _ heap) hr = go [hr] hr
where
go visited ref
| rr@(HeapRef r) <- heap M.! ref =
if r == ref || r `elem` visited
then rec rr ref
else go (r : visited) r
| s@(Struct (IR.Id _ arity)) <- heap M.! ref =
sequence [go (ref + i : visited) (ref + i) | i <- [1 .. arity]] >>=
struct s
| x <- heap M.! ref = atom x
|
