looks like vars work

This commit is contained in:
Mirek Kratochvil 2022-11-11 22:10:26 +01:00
parent 5d186de9c8
commit fe6666d204
3 changed files with 47 additions and 34 deletions

View file

@ -1,5 +1,7 @@
module Compiler where module Compiler where
import Data.Char (isUpper)
import Data.Containers.ListUtils (nubOrd)
import Data.List import Data.List
import Interpreter (Code, Datum(..), Id(..), Instr(..), StrTable, strtablize) import Interpreter (Code, Datum(..), Id(..), Instr(..), StrTable, strtablize)
@ -10,13 +12,29 @@ data PrlgStr
data PrlgInt data PrlgInt
= CallI Id [PrlgInt] = CallI Id [PrlgInt]
| LiteralI Int --split off vars here later | LiteralI Int
| VarI Int Int
| VoidI
deriving (Show) deriving (Show)
strtablizePrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt) varname :: String -> Bool
strtablizePrlg = go varname ('_':_) = True
varname (c:_) = isUpper c
varname _ = False
varnames :: PrlgStr -> [String]
varnames (CallS _ xs) = nubOrd $ concatMap varnames xs
varnames (LiteralS x)
| varname x = [x]
| otherwise = []
strtablizePrlg :: [String] -> StrTable -> PrlgStr -> (StrTable, PrlgInt)
strtablizePrlg stab = go
where where
go t (LiteralS str) = LiteralI <$> strtablize t str go t (LiteralS str)
| str == "_" = (t, VoidI)
| Just idx <- elemIndex str stab = VarI idx <$> strtablize t str
| otherwise = LiteralI <$> strtablize t str
go t (CallS str ps) = go t (CallS str ps) =
let (t', i) = strtablize t str let (t', i) = strtablize t str
in CallI (Id i $ length ps) <$> mapAccumL go t' ps in CallI (Id i $ length ps) <$> mapAccumL go t' ps
@ -35,6 +53,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 VoidI = [U VoidRef]
seqGoals :: [Code] -> Code seqGoals :: [Code] -> Code
seqGoals [] = [NoGoal] seqGoals [] = [NoGoal]

View file

@ -66,7 +66,8 @@ 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 $ flip C.strtablizePrlg prlgs prlgi <-
withStrTable $ \st -> C.strtablizePrlg (C.varnames prlgs) st prlgs
compile prlgi compile prlgi
compile prlgi compile prlgi
{- TODO: switch between prove goal/compile clause here -} {- TODO: switch between prove goal/compile clause here -}
@ -93,18 +94,23 @@ addBuiltins = do
c <- findAtom "c" c <- findAtom "c"
b0 <- findStruct "b" 0 b0 <- findStruct "b" 0
any <- findStruct "any" 1 any <- findStruct "any" 1
eq <- findStruct "=" 2
modify $ \s -> modify $ \s ->
s s
{ defs = { defs =
M.fromList M.fromList
[ (a1, [[I.U (I.Atom a), I.NoGoal], [I.U (I.Atom b), I.NoGoal]]) [ (eq, [[I.U (I.LocalRef 0),I.U (I.LocalRef 0), I.NoGoal]])
, (a1, [[I.U (I.Atom a), I.NoGoal], [I.U (I.Atom b), I.NoGoal]])
, ( b0 , ( b0
, [ [I.Goal, I.U (I.Struct a1), I.U (I.Atom c), I.LastCall] , [ [I.Goal, I.U (I.Struct a1), I.U (I.Atom c), I.LastCall]
, [I.Goal, I.U (I.Struct a1), I.U (I.Atom b), I.LastCall] , [I.Goal, I.U (I.Struct a1), I.U (I.Atom b), I.LastCall]
]) ])
, (any, [[I.U I.VoidVar, I.NoGoal]]) , (any, [[I.U I.VoidRef, I.NoGoal]])
] ]
, ops = [(",", P.Op 1000 $ P.Infix P.X P.Y)] , ops =
[ (",", P.Op 1000 $ P.Infix P.X P.Y)
, ("=", P.Op 700 $ P.Infix P.X P.X)
]
} }
interpreterStart :: PrlgEnv () interpreterStart :: PrlgEnv ()

View file

@ -25,7 +25,7 @@ data 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
| VoidVar -- in code this unifies with anything; everywhere else this is an unbound variable | VoidRef -- in code this unifies with anything; everywhere else this is an unbound variable
| LocalRef Int -- local variable idx | LocalRef Int -- local variable idx
| HeapRef Int -- heap structure idx | HeapRef Int -- heap structure idx
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -47,7 +47,7 @@ data Heap =
Heap Int (M.Map Int Datum) Heap Int (M.Map Int Datum)
deriving (Show) deriving (Show)
emptyHeap = Heap 1 M.empty emptyHeap = Heap 0 M.empty
type Scope = M.Map Int Int type Scope = M.Map Int Int
@ -154,35 +154,22 @@ proveStep c f i = go i
m' m'
in cont (map HeapRef $ tail addrs) (Heap nxt' m'') in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
{- simple cases first -} {- simple cases first -}
unify VoidVar VoidVar = uok unify VoidRef VoidRef = uok
unify (Atom a) (Atom b) unify (Atom a) (Atom b)
| a == b = uok | a == b = uok
unify VoidVar (Atom _) = uok unify VoidRef (Atom _) = uok
unify (Atom _) VoidVar = 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 VoidVar (Struct Id {arity = a}) = unify VoidRef (Struct Id {arity = a}) =
c i {cur = cur {hed = replicate a (U VoidVar) ++ hs, gol = gs}} c i {cur = cur {hed = replicate a (U VoidRef) ++ hs, gol = gs}}
unify (Struct Id {arity = a}) VoidVar = unify (Struct Id {arity = a}) VoidRef =
c i {cur = cur {hed = hs, gol = replicate a (U VoidVar) ++ gs}} c i {cur = cur {hed = hs, gol = replicate a (U VoidRef) ++ 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 _) VoidVar = uok unify (LocalRef _) VoidRef = uok
unify VoidVar (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) (LocalRef gv) =
allocLocal gv (gvar cur) $ \gvar' heap' addr ->
c
i
{ cur =
cur
{ hed = U (HeapRef addr) : hs
, hvar = M.insert hv addr (hvar cur)
, gol = U (HeapRef addr) : gs
, gvar = gvar'
, heap = heap'
}
}
unify (LocalRef hv) _ = unify (LocalRef hv) _ =
allocLocal hv (hvar cur) $ \hvar' heap' addr -> allocLocal hv (hvar cur) $ \hvar' heap' addr ->
c c
@ -200,8 +187,8 @@ proveStep c f i = go i
{gol = U (HeapRef addr) : gs, gvar = gvar', heap = heap'} {gol = U (HeapRef addr) : 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 _) VoidVar = uok unify (HeapRef _) VoidRef = uok
unify VoidVar (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; decide between copying and linking -}
unify (HeapRef hr') g = unify (HeapRef hr') g =
case deref hr' of case deref hr' of