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

struct structs

Browse source
This commit is contained in:
Mirek Kratochvil 2023-01-03 15:51:12 +01:00
parent 2f07d89043
commit 506551ab75
3 changed files with 87 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
app/Builtins.hs
View file

@ -12,6 +12,7 @@ import Code
, InterpFn
, derefHeap
, heapStruct
, newHeapVars
)
import qualified Compiler as Co
import Control.Monad.IO.Class (liftIO)
@ -20,6 +21,7 @@ import Control.Monad.Trans.State.Lazy (get, gets, modify)
import Data.Functor.Identity (runIdentity)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
import qualified IR
import Interpreter (backtrack)
@ -149,10 +151,64 @@ call =
exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
_ -> prlgError "not callable"
{- struct building -}
struct :: InterpFn
struct = do
heap <- gets (heap . cur)
scope <- gets (hvar . cur)
prlgError "not yet"
case derefHeap heap <$> scope M.!? 0 of
Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
structUnify arity str
_ -> structAssemble
heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
where
nil r
| BoundRef _ str <- derefHeap heap r = str == Atom listAtom
| otherwise = False
step r
| BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
derefHeap heap r
, listAtom == listAtom' = Just (addr + 2)
| otherwise = Nothing
go n fast slow (f1, f2)
| nil fast = Just n
| Just fast' <- step fast =
if slow == fast'
then Nothing
else go (n + 1) fast' (f1 slow) (f2, f1)
| otherwise = Nothing
structAssemble :: InterpFn
structAssemble = do
heap <- gets (heap . cur)
scope <- gets (hvar . cur)
case derefHeap heap <$> scope M.!? 1 of
Just (BoundRef addr (Atom str)) -> do
listAtom <- findAtom "[]"
case scope M.!? 2 >>= heapListLength listAtom heap of
Just arity -> structUnify arity str
_ -> prlgError "struct arity unknown"
_ -> prlgError "struct id unknown"
structUnify arity str = do
cur <- gets cur
let h = heap cur
scope = hvar cur
listAtom <- findAtom "[]"
let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
(h', pvars) = newHeapVars arity h
structData =
Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
paramsData =
concatMap
(\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
pvars ++
[Atom listAtom]
gcode = map U $ structData ++ [Atom str] ++ paramsData
modify $ \s ->
s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}}
return Nothing
{- adding the builtins -}
addOp op = modify $ \s -> s {ops = op : ops s}

20
app/Code.hs
View file

@ -77,6 +77,7 @@ 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
@ -89,6 +90,25 @@ derefHeap h@(Heap _ hmap) 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

29
app/Interpreter.hs
View file

@ -7,13 +7,15 @@ import Code
, Code
, Datum(..)
, Dereferenced(..)
, Heap(..)
, Instr(..)
, Interp(..)
, InterpFn
, derefHeap
, emptyHeap
, emptyScope
, newHeapVar
, withNewHeapStruct
, writeHeap
)
import qualified Control.Monad.Trans.State.Lazy as St
import Env (PrlgEnv)
@ -82,23 +84,10 @@ proveStep = St.get >>= go
c i {cur = cur {hed = hs, gol = gs, heap = writeHeap r x heap}}
{- heap tools -}
deref = derefHeap heap
writeHeap addr x (Heap nxt m) = Heap nxt (M.adjust (const x) addr m)
newHeapVar h = head <$> newHeapVars 1 h
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)
allocLocal (LocalRef reg) scope cont
withNewLocal (LocalRef reg) scope cont
| Just addr <- scope M.!? reg = cont scope heap addr
| (heap', addr) <- newHeapVar heap =
cont (M.insert reg addr 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) . M.insert (head addrs) s $
m'
in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
{- simple cases first -}
unify VoidRef VoidRef = uok
unify (Atom a) (Atom b)
@ -117,7 +106,7 @@ proveStep = St.get >>= go
unify VoidRef (LocalRef _) = uok
{- allocate heap for LocalRefs and retry with HeapRefs -}
unify lr@(LocalRef _) _ =
allocLocal lr (hvar cur) $ \hvar' heap' addr ->
withNewLocal lr (hvar cur) $ \hvar' heap' addr ->
c
i
{ cur =
@ -125,7 +114,7 @@ proveStep = St.get >>= go
{hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'}
}
unify _ lr@(LocalRef _) =
allocLocal lr (gvar cur) $ \gvar' heap' addr ->
withNewLocal lr (gvar cur) $ \gvar' heap' addr ->
c
i
{ cur =
@ -142,9 +131,10 @@ proveStep = St.get >>= go
case g of
atom@(Atom _) -> setHeap hr atom
s@(Struct _) ->
newHeapStruct
withNewHeapStruct
hr
s
heap
(\nhs nheap ->
c
i
@ -176,9 +166,10 @@ proveStep = St.get >>= go
case h of
atom@(Atom _) -> setHeap gr atom
s@(Struct _) ->
newHeapStruct
withNewHeapStruct
gr
s
heap
(\ngs nheap ->
c
i