exa/prlg
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

compiled vars carry ids

Browse source
This commit is contained in:
Mirek Kratochvil 2022-11-12 18:45:13 +01:00
parent b9633a3318
commit a736c1e7b7
6 changed files with 82 additions and 66 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
app/Builtins.hs
View file

@ -19,13 +19,13 @@ addBuiltins = do
s s
{ defs = { defs =
M.fromList M.fromList
[ (eq, [[U (LocalRef 0), U (LocalRef 0), NoGoal]]) [ (eq, [[U (LocalRef 0 Nothing), U (LocalRef 0 Nothing), NoGoal]])
, (a1, [[U (Atom a), NoGoal], [U (Atom b), NoGoal]]) , (a1, [[U (Atom a), NoGoal], [U (Atom b), NoGoal]])
, ( b0 , ( b0
, [ [Goal, U (Struct a1), U (Atom c), LastCall] , [ [Goal, U (Struct a1), U (Atom c), LastCall]
, [Goal, U (Struct a1), U (Atom b), LastCall] , [Goal, U (Struct a1), U (Atom b), LastCall]
]) ])
, (any, [[U VoidRef, NoGoal]]) , (any, [[U (VoidRef Nothing), NoGoal]])
] ]
, ops = [(O.xfy "," 1000), (O.xfx "=" 700)] , ops = [(O.xfy "," 1000), (O.xfx "=" 700)]
} }

6
app/Code.hs
View file

@ -6,9 +6,9 @@ import IR (Id(..))
data Datum data Datum
= Atom Int -- unifies a constant = Atom Int -- unifies a constant
| Struct Id -- unifies a structure with arity | Struct Id -- unifies a structure with arity
| VoidRef -- unifies with anything | VoidRef (Maybe Int) -- unifies with anything (references may refer to variable names)
| LocalRef Int -- code-local variable idx (should not occur on heap) | LocalRef Int (Maybe Int) -- code-local variable idx (should not occur on heap)
| HeapRef Int -- heap structure idx | HeapRef Int (Maybe Int) -- heap structure idx
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
data Instr data Instr

51
app/Compiler.hs
View file

@ -3,31 +3,38 @@ module Compiler where
import Data.Char (isUpper) import Data.Char (isUpper)
import Data.Containers.ListUtils (nubOrd) import Data.Containers.ListUtils (nubOrd)
import Data.List import Data.List
import qualified Data.Map as M
import Code (Code, Datum(..), Instr(..)) import Code (Code, Datum(..), Instr(..))
import IR (Id(..), PrlgInt(..), PrlgStr(..), StrTable, strtablize) import IR (Id(..), PrlgInt(..), PrlgStr(..), StrTable(..), strtablize)
internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
internPrlg = go
where
go t (LiteralS str) = LiteralI <$> strtablize t str
go t (CallS str ps) =
let (t', i) = strtablize t str
in CallI (Id i $ length ps) <$> mapAccumL go t' ps
varname :: String -> Bool varname :: String -> Bool
varname ('_':_) = True varname ('_':_) = True
varname (c:_) = isUpper c varname (c:_) = isUpper c
varname _ = False varname _ = False
varnames :: PrlgStr -> [String] varIds :: StrTable -> PrlgInt -> [Int]
varnames (CallS _ xs) = nubOrd $ concatMap varnames xs varIds st (CallI _ xs) = nubOrd $ concatMap (varIds st) xs
varnames (LiteralS x) varIds (StrTable _ _ st) (LiteralI x)
| varname x = [x] | Just s <- st M.!? x
, varname s = [x]
| otherwise = [] | otherwise = []
internPrlg :: [String] -> StrTable -> PrlgStr -> (StrTable, PrlgInt) variablizePrlg :: Int -> [Int] -> PrlgInt -> PrlgInt
internPrlg stab = go variablizePrlg void vs (CallI id ps) =
where CallI id $ map (variablizePrlg void vs) ps
go t (LiteralS str) variablizePrlg void vs (LiteralI i)
| str == "_" = (t, VoidI) | i == void = VoidI i
| Just idx <- elemIndex str stab = VarI idx <$> strtablize t str | Just idx <- elemIndex i vs = VarI idx i
| otherwise = LiteralI <$> strtablize t str | otherwise = LiteralI i
go t (CallS str ps) =
let (t', i) = strtablize t str
in CallI (Id i $ length ps) <$> mapAccumL go t' ps
compileGoals :: Id -> PrlgInt -> [Code] compileGoals :: Id -> PrlgInt -> [Code]
compileGoals andop = go compileGoals andop = go
@ -43,8 +50,8 @@ compileGoal x = compileArg x
compileArg :: PrlgInt -> Code compileArg :: PrlgInt -> Code
compileArg (CallI x args) = U (Struct x) : concatMap compileArg args compileArg (CallI x args) = U (Struct x) : concatMap compileArg args
compileArg (LiteralI x) = [U (Atom x)] compileArg (LiteralI x) = [U (Atom x)]
compileArg (VarI x _) = [U (LocalRef x)] compileArg (VarI x i) = [U (LocalRef x $ Just i)]
compileArg VoidI = [U VoidRef] compileArg (VoidI i) = [U (VoidRef $ Just i)]
seqGoals :: [Code] -> Code seqGoals :: [Code] -> Code
seqGoals [] = [NoGoal] seqGoals [] = [NoGoal]
@ -52,13 +59,3 @@ seqGoals [[Cut]] = [Cut, NoGoal]
seqGoals [x] = [Goal] ++ x ++ [LastCall] seqGoals [x] = [Goal] ++ x ++ [LastCall]
seqGoals [x, [Cut]] = [Goal] ++ x ++ [LastCall, Cut] seqGoals [x, [Cut]] = [Goal] ++ x ++ [LastCall, Cut]
seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs
compileClause :: Id -> Id -> PrlgInt -> Code
compileClause proveop andop = go
where
go :: PrlgInt -> Code
go h@(CallI x args)
| x == proveop
, [head, goals] <- args =
compileGoal head ++ seqGoals (compileGoals andop goals)
| otherwise = compileGoal h ++ seqGoals []

14
app/Frontend.hs
View file

@ -45,13 +45,15 @@ interpret = (>> return True) . lex
Left err -> liftIO $ putStrLn $ "expression parsing: " ++ err Left err -> liftIO $ putStrLn $ "expression parsing: " ++ err
Right prlg -> intern prlg Right prlg -> intern prlg
intern prlgs = do intern prlgs = do
prlgi <- withStrTable $ \st -> C.internPrlg (C.varnames prlgs) st prlgs prlgi <- withStrTable $ \st -> C.internPrlg st prlgs
compile prlgi underscore <- findAtom "_"
compile prlgi prlgv <-
{- TODO: switch between prove goal/compile clause here -} withStrTable $ \st ->
= do (st, C.variablizePrlg underscore (C.varIds st prlgi) prlgi)
compile prlgv
compile prlgv = do
commaId <- findStruct "," 2 commaId <- findStruct "," 2
let code = C.seqGoals $ C.compileGoals commaId prlgi let code = C.seqGoals $ C.compileGoals commaId prlgv
execute code execute code
execute code = do execute code = do
ds <- gets defs ds <- gets defs

2
app/IR.hs
View file

@ -18,7 +18,7 @@ data PrlgInt
= CallI Id [PrlgInt] = CallI Id [PrlgInt]
| LiteralI Int | LiteralI Int
| VarI Int Int | VarI Int Int
| VoidI | VoidI Int
deriving (Show) deriving (Show)
data StrTable = data StrTable =

71
app/Interpreter.hs
View file

@ -63,7 +63,7 @@ proveStep c f i = go i
{- heap tools -} {- heap tools -}
deref x = deref x =
case hmap M.!? x of case hmap M.!? x of
Just (HeapRef x') -> Just (HeapRef x' _) ->
if x == x' if x == x'
then FreeRef x' then FreeRef x'
else deref x' else deref x'
@ -74,7 +74,7 @@ proveStep c f i = go i
newHeapVars n (Heap nxt m) = newHeapVars n (Heap nxt m) =
let addrs = [nxt + i - 1 | i <- [1 .. n]] let addrs = [nxt + i - 1 | i <- [1 .. n]]
in ( Heap (nxt + n) $ in ( Heap (nxt + n) $
foldr (uncurry M.insert) m $ zip addrs (map HeapRef addrs) foldr (uncurry M.insert) m [(a, HeapRef a Nothing) | a <- addrs]
, addrs) , addrs)
allocLocal reg scope cont allocLocal reg scope cont
| Just addr <- scope M.!? reg = cont scope heap addr | Just addr <- scope M.!? reg = cont scope heap addr
@ -83,47 +83,62 @@ proveStep c f i = go i
newHeapStruct addr s@(Struct Id {arity = arity}) cont = newHeapStruct addr s@(Struct Id {arity = arity}) cont =
let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
m'' = m'' =
M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ M.insert addr (HeapRef (head addrs) Nothing) .
M.insert (head addrs) s $
m' m'
in cont (map HeapRef $ tail addrs) (Heap nxt' m'') in cont [HeapRef a Nothing | a <- tail addrs] (Heap nxt' m'')
{- simple cases first -} {- simple cases first -}
unify VoidRef VoidRef = uok unify (VoidRef _) (VoidRef _) = uok
unify (Atom a) (Atom b) unify (Atom a) (Atom b)
| a == b = uok | a == b = uok
unify VoidRef (Atom _) = uok unify (VoidRef _) (Atom _) = uok
unify (Atom _) VoidRef = uok unify (Atom _) (VoidRef _) = uok
unify (Struct a) (Struct b) unify (Struct a) (Struct b)
| a == b = uok | a == b = uok
{- unifying a struct with void must cause us to skip the void -} {- unifying a struct with void must cause us to skip the void -}
unify VoidRef (Struct Id {arity = a}) = unify (VoidRef _) (Struct Id {arity = a}) =
c i {cur = cur {hed = replicate a (U VoidRef) ++ hs, gol = gs}} c
unify (Struct Id {arity = a}) VoidRef = i
c i {cur = cur {hed = hs, gol = replicate a (U VoidRef) ++ gs}} { 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}
}
{- handle local refs; first ignore their combination with voids to save memory -} {- handle local refs; first ignore their combination with voids to save memory -}
unify (LocalRef _) VoidRef = uok unify (LocalRef _ _) (VoidRef _) = uok
unify VoidRef (LocalRef _) = uok unify (VoidRef _) (LocalRef _ _) = uok
{- allocate heap for LocalRefs and retry with HeapRefs -} {- allocate heap for LocalRefs and retry with HeapRefs -}
unify (LocalRef hv) _ = unify (LocalRef hv ident) _ =
allocLocal hv (hvar cur) $ \hvar' heap' addr -> allocLocal hv (hvar cur) $ \hvar' heap' addr ->
c c
i i
{ cur = { cur =
cur cur
{hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'} { hed = U (HeapRef addr ident) : hs
, hvar = hvar'
, heap = heap'
} }
unify _ (LocalRef gv) = }
unify _ (LocalRef gv ident) =
allocLocal gv (gvar cur) $ \gvar' heap' addr -> allocLocal gv (gvar cur) $ \gvar' heap' addr ->
c c
i i
{ cur = { cur =
cur cur
{gol = U (HeapRef addr) : gs, gvar = gvar', heap = heap'} { gol = U (HeapRef addr ident) : gs
, gvar = gvar'
, heap = heap'
}
} }
{- handle heap refs; first ignore their combination with voids again -} {- handle heap refs; first ignore their combination with voids again -}
unify (HeapRef _) VoidRef = uok unify (HeapRef _ _) (VoidRef _) = uok
unify VoidRef (HeapRef _) = uok unify (VoidRef _) (HeapRef _ _) = uok
{- actual HeapRefs, these are dereferenced and then unified; decide between copying and linking -} {- actual HeapRefs, these are dereferenced and then unified (sometimes with copying) -}
unify (HeapRef hr') g = unify (HeapRef hr' hident) g =
case deref hr' of case deref hr' of
FreeRef hr -> FreeRef hr ->
case g of case g of
@ -139,10 +154,10 @@ proveStep c f i = go i
cur cur
{hed = map U nhs ++ hs, gol = gs, heap = nheap} {hed = map U nhs ++ hs, gol = gs, heap = nheap}
}) })
HeapRef gr' -> HeapRef gr' _ ->
case deref gr' of case deref gr' of
FreeRef gr -> setHeap hr (HeapRef gr) FreeRef gr -> setHeap hr (HeapRef gr hident)
BoundRef addr _ -> setHeap hr (HeapRef addr) BoundRef addr _ -> setHeap hr (HeapRef addr hident)
_ -> ifail "dangling goal ref (from head ref)" _ -> ifail "dangling goal ref (from head ref)"
BoundRef _ atom@(Atom a) -> unify atom g BoundRef _ atom@(Atom a) -> unify atom g
BoundRef addr struct@(Struct Id {arity = arity}) -> BoundRef addr struct@(Struct Id {arity = arity}) ->
@ -152,12 +167,13 @@ proveStep c f i = go i
cur cur
{ hed = { hed =
U struct : U struct :
[U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ hs [U (HeapRef (addr + i) Nothing) | i <- [1 .. arity]] ++
hs
, gol = U g : gs , gol = U g : gs
} }
} }
_ -> ifail "dangling head ref" _ -> ifail "dangling head ref"
unify h (HeapRef gr') = unify h (HeapRef gr' gident) =
case deref gr' of case deref gr' of
FreeRef gr -> FreeRef gr ->
case h of case h of
@ -182,7 +198,8 @@ proveStep c f i = go i
{ hed = U h : hs { hed = U h : hs
, gol = , gol =
U struct : U struct :
[U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ gs [U (HeapRef (addr + i) Nothing) | i <- [1 .. arity]] ++
gs
} }
} }
_ -> ifail "dangling goal ref" _ -> ifail "dangling goal ref"