looks like vars work
This commit is contained in:
parent
5d186de9c8
commit
fe6666d204
|
@ -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]
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue