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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
{-# 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 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 -- something unifiable
| NoGoal -- trivial goal (directly after head)
| Invoke Builtin -- also directly after head
| Goal -- a new goal (set head)
| Call -- all seems okay, call the head's hoal
| LastCall -- tail call the head's goal
| Cut -- remove all alternative clauses of the current goal
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
, heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
, stk :: [(Code, Scope, [Cho])] -- remaining goals together with their vars and cuts
, 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
, strtable :: StrTable -- string table
}
deriving (Show)
type PrlgEnv a = StateT Interp (InputT IO) a
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)
-- 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'')
-- TODO are we actually going to use this?
codeStruct ::
Monad m
=> (Datum -> m a)
-> (Datum -> [a] -> m a)
-> (Datum -> m (Either Int a))
-> (Datum -> Int -> m a)
-> m a
-> Heap
-> Code
-> m (Code, a)
codeStruct atom struct local rec end heap = go
where
go [] = ([], ) <$> end
go (U lr@(LocalRef _):cs) = do
x <- local lr
case x of
Left ref -> (cs, ) <$> heapStruct atom struct rec heap ref
Right a -> pure (cs, a)
go (U s@(Struct (IR.Id _ arity)):cs) = eat arity cs >>= traverse (struct s)
go (U x:cs) = (cs, ) <$> atom x
go cs = (cs, ) <$> end
eat n cs
| n <= 0 = pure (cs, [])
| otherwise = do
(rest, a) <- go cs
fmap (a :) <$> eat (n - 1) rest
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
|
