diff --git a/app/Builtins.hs b/app/Builtins.hs index 9e4215c..53ebe82 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -10,10 +10,14 @@ import qualified Operators as O bi = Builtin -hello = - bi $ do - liftIO $ putStrLn "hllo prlg" - return Nothing +hello :: BuiltinFn +hello = do + liftIO $ putStrLn "hllo prlg" + return Nothing + +printLocals :: BuiltinFn +printLocals = do + return Nothing addBuiltins :: PrlgEnv () addBuiltins = do @@ -21,28 +25,30 @@ addBuiltins = do a <- findAtom "a" b <- findAtom "b" c <- findAtom "c" + varX <- findAtom "X" b0 <- findStruct "b" 0 any1 <- findStruct "any" 1 eq2 <- findStruct "=" 2 hello0 <- findStruct "hello" 0 fail0 <- findStruct "fail" 0 true0 <- findStruct "true" 0 - prlgstate0 <- findStruct "prlgstate" 0 + printlocals0 <- findStruct "print_locals" 0 + debugprint0 <- findStruct "interpreter_state" 0 modify $ \s -> s { defs = M.fromList - [ (eq2, [[U (LocalRef 0 Nothing), U (LocalRef 0 Nothing), NoGoal]]) + [ (eq2, [[U (LocalRef 0 varX), U (LocalRef 0 varX), NoGoal]]) , (a1, [[U (Atom a), NoGoal], [U (Atom b), NoGoal]]) , ( b0 , [ [Goal, U (Struct a1), U (Atom c), LastCall] , [Goal, U (Struct a1), U (Atom b), LastCall] ]) - , (any1, [[U (VoidRef Nothing), NoGoal]]) - , (hello0, [[Invoke hello]]) + , (any1, [[U VoidRef, NoGoal]]) + , (hello0, [[Invoke $ bi hello]]) , (fail0, [[Invoke $ bi backtrack]]) , (true0, [[Invoke $ bi (pure Nothing)]]) - , ( prlgstate0 + , ( debugprint0 , [[Invoke $ bi (get >>= liftIO . print >> pure Nothing)]]) ] , ops = [(O.xfy "," 1000), (O.xfx "=" 700)] diff --git a/app/Code.hs b/app/Code.hs index 5721d17..df3401e 100644 --- a/app/Code.hs +++ b/app/Code.hs @@ -9,9 +9,9 @@ import System.Console.Haskeline data Datum = Atom Int -- unifies a constant | Struct Id -- unifies a structure with arity - | VoidRef (Maybe Int) -- unifies with anything (references may refer to variable names) - | LocalRef Int (Maybe Int) -- code-local variable idx (should not occur on heap) - | HeapRef Int (Maybe Int) -- heap structure idx + | VoidRef -- unifies with anything + | LocalRef Int Int -- code-local variable idx (should never occur on heap) + | HeapRef Int -- something further on the heap deriving (Show, Eq, Ord) data Instr @@ -34,7 +34,7 @@ data Heap = emptyHeap = Heap 0 M.empty -type Scope = M.Map Int Int +type Scope = M.Map Int (Int, Int) emptyScope :: Scope emptyScope = M.empty diff --git a/app/Compiler.hs b/app/Compiler.hs index e9bd7f4..1adefc3 100644 --- a/app/Compiler.hs +++ b/app/Compiler.hs @@ -32,7 +32,7 @@ variablizePrlg :: Int -> [Int] -> PrlgInt -> PrlgInt variablizePrlg void vs (CallI id ps) = CallI id $ map (variablizePrlg void vs) ps variablizePrlg void vs (LiteralI i) - | i == void = VoidI i + | i == void = VoidI | Just idx <- elemIndex i vs = VarI idx i | otherwise = LiteralI i @@ -50,8 +50,8 @@ compileGoal x = compileArg x compileArg :: PrlgInt -> Code compileArg (CallI x args) = U (Struct x) : concatMap compileArg args compileArg (LiteralI x) = [U (Atom x)] -compileArg (VarI x i) = [U (LocalRef x $ Just i)] -compileArg (VoidI i) = [U (VoidRef $ Just i)] +compileArg (VarI x i) = [U (LocalRef x i)] +compileArg (VoidI) = [U VoidRef] seqGoals :: [Code] -> Code seqGoals [] = [NoGoal] diff --git a/app/IR.hs b/app/IR.hs index e1aa9ba..50c7493 100644 --- a/app/IR.hs +++ b/app/IR.hs @@ -18,7 +18,7 @@ data PrlgInt = CallI Id [PrlgInt] | LiteralI Int | VarI Int Int - | VoidI Int + | VoidI deriving (Show) data StrTable = diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 3d1c569..ada3cf0 100644 --- a/app/Interpreter.hs +++ b/app/Interpreter.hs @@ -69,7 +69,6 @@ proveStep = St.get >>= go , gol = U g:gs , heap = heap@(Heap _ hmap) }} = unify h g - {- termination tools -} where uok = c i {cur = cur {hed = hs, gol = gs}} setHeap r x = @@ -77,7 +76,7 @@ proveStep = St.get >>= go {- heap tools -} deref x = case hmap M.!? x of - Just (HeapRef x' _) -> + Just (HeapRef x') -> if x == x' then FreeRef x' else deref x' @@ -88,71 +87,56 @@ proveStep = St.get >>= go 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 Nothing) | a <- addrs] + foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs] , addrs) - allocLocal reg scope cont - | Just addr <- scope M.!? reg = cont scope heap addr + allocLocal (LocalRef reg ident) scope cont + | Just (addr, _) <- scope M.!? reg = cont scope heap addr | (heap', addr) <- newHeapVar heap = - cont (M.insert reg addr scope) heap' addr + cont (M.insert reg (addr, ident) scope) heap' addr newHeapStruct addr s@(Struct Id {arity = arity}) cont = let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap m'' = - M.insert addr (HeapRef (head addrs) Nothing) . - M.insert (head addrs) s $ + M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ m' - in cont [HeapRef a Nothing | a <- tail addrs] (Heap nxt' m'') + in cont (map HeapRef $ tail addrs) (Heap nxt' m'') {- simple cases first -} - unify (VoidRef _) (VoidRef _) = uok + unify VoidRef VoidRef = uok unify (Atom a) (Atom b) | a == b = uok - unify (VoidRef _) (Atom _) = uok - unify (Atom _) (VoidRef _) = uok + unify VoidRef (Atom _) = uok + unify (Atom _) VoidRef = uok unify (Struct a) (Struct b) | a == b = uok {- unifying a struct with void must cause us to skip the void -} - unify (VoidRef _) (Struct Id {arity = a}) = - c - i - { cur = - cur {hed = replicate a (U $ VoidRef Nothing) ++ hs, gol = gs} - } - unify (Struct Id {arity = a}) (VoidRef _) = - c - i - { cur = - cur {hed = hs, gol = replicate a (U $ VoidRef Nothing) ++ gs} - } + unify VoidRef (Struct Id {arity = a}) = + c i {cur = cur {hed = replicate a (U VoidRef) ++ hs, gol = gs}} + unify (Struct Id {arity = a}) VoidRef = + c i {cur = cur {hed = hs, gol = replicate a (U VoidRef) ++ gs}} {- handle local refs; first ignore their combination with voids to save memory -} - unify (LocalRef _ _) (VoidRef _) = uok - unify (VoidRef _) (LocalRef _ _) = uok + unify (LocalRef _ _) VoidRef = uok + unify VoidRef (LocalRef _ _) = uok {- allocate heap for LocalRefs and retry with HeapRefs -} - unify (LocalRef hv ident) _ = - allocLocal hv (hvar cur) $ \hvar' heap' addr -> + unify lr@(LocalRef _ _) _ = + allocLocal lr (hvar cur) $ \hvar' heap' addr -> c i { cur = cur - { hed = U (HeapRef addr ident) : hs - , hvar = hvar' - , heap = heap' - } + {hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'} } - unify _ (LocalRef gv ident) = - allocLocal gv (gvar cur) $ \gvar' heap' addr -> + unify _ lr@(LocalRef _ _) = + allocLocal lr (gvar cur) $ \gvar' heap' addr -> c i { cur = cur - { gol = U (HeapRef addr ident) : gs - , gvar = gvar' - , heap = heap' - } + {gol = U (HeapRef addr) : gs, gvar = gvar', heap = heap'} } {- handle heap refs; first ignore their combination with voids again -} - unify (HeapRef _ _) (VoidRef _) = uok - unify (VoidRef _) (HeapRef _ _) = uok + unify (HeapRef _) VoidRef = uok + unify VoidRef (HeapRef _) = uok {- actual HeapRefs, these are dereferenced and then unified (sometimes with copying) -} - unify (HeapRef hr' hident) g = + unify (HeapRef hr') g = case deref hr' of FreeRef hr -> case g of @@ -168,10 +152,10 @@ proveStep = St.get >>= go cur {hed = map U nhs ++ hs, gol = gs, heap = nheap} }) - HeapRef gr' _ -> + HeapRef gr' -> case deref gr' of - FreeRef gr -> setHeap hr (HeapRef gr hident) - BoundRef addr _ -> setHeap hr (HeapRef addr hident) + FreeRef gr -> setHeap hr (HeapRef gr) + BoundRef addr _ -> setHeap hr (HeapRef addr) _ -> ifail "dangling goal ref (from head ref)" BoundRef _ atom@(Atom a) -> unify atom g BoundRef addr struct@(Struct Id {arity = arity}) -> @@ -181,13 +165,12 @@ proveStep = St.get >>= go cur { hed = U struct : - [U (HeapRef (addr + i) Nothing) | i <- [1 .. arity]] ++ - hs + [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ hs , gol = U g : gs } } _ -> ifail "dangling head ref" - unify h (HeapRef gr' gident) = + unify h (HeapRef gr') = case deref gr' of FreeRef gr -> case h of @@ -212,8 +195,7 @@ proveStep = St.get >>= go { hed = U h : hs , gol = U struct : - [U (HeapRef (addr + i) Nothing) | i <- [1 .. arity]] ++ - gs + [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ gs } } _ -> ifail "dangling goal ref"