mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-05 06:07:21 +03:00
progress
This commit is contained in:
Paul Chiusano
parent
e097de5d2c
commit
b1c2d120b9
@ -1,6 +1,9 @@
|
||||
{-# Language DeriveFoldable #-}
|
||||
{-# Language DeriveFunctor #-}
|
||||
{-# Language DeriveTraversable #-}
|
||||
{-# Language FlexibleContexts #-}
|
||||
{-# Language PartialTypeSignatures #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language PartialTypeSignatures #-}
|
||||
{-# Language StrictData #-}
|
||||
{-# Language TupleSections #-}
|
||||
|
||||
@ -77,34 +80,39 @@ data Pattern
|
||||
-- Leaf level instructions - these return immediately without using any stack
|
||||
data Z = Slot Pos | LazySlot Pos | Val V deriving (Eq)
|
||||
|
||||
type IR = IR' Z
|
||||
|
||||
-- IR z
|
||||
-- depth of a slot is just that slot
|
||||
-- depth of a let is just depth
|
||||
--
|
||||
-- Computations - evaluation reduces these to values
|
||||
data IR
|
||||
= Leaf Z
|
||||
data IR' z
|
||||
= Leaf z
|
||||
-- Ints
|
||||
| AddI Z Z | SubI Z Z | MultI Z Z | DivI Z Z
|
||||
| GtI Z Z | LtI Z Z | GtEqI Z Z | LtEqI Z Z | EqI Z Z
|
||||
| AddI z z | SubI z z | MultI z z | DivI z z
|
||||
| GtI z z | LtI z z | GtEqI z z | LtEqI z z | EqI z z
|
||||
-- Nats
|
||||
| AddN Z Z | DropN Z Z | SubN Z Z | MultN Z Z | DivN Z Z
|
||||
| GtN Z Z | LtN Z Z | GtEqN Z Z | LtEqN Z Z | EqN Z Z
|
||||
| AddN z z | DropN z z | SubN z z | MultN z z | DivN z z
|
||||
| GtN z z | LtN z z | GtEqN z z | LtEqN z z | EqN z z
|
||||
-- Floats
|
||||
| AddF Z Z | SubF Z Z | MultF Z Z | DivF Z Z
|
||||
| GtF Z Z | LtF Z Z | GtEqF Z Z | LtEqF Z Z | EqF Z Z
|
||||
| AddF z z | SubF z z | MultF z z | DivF z z
|
||||
| GtF z z | LtF z z | GtEqF z z | LtEqF z z | EqF z z
|
||||
-- Control flow
|
||||
| Let IR IR
|
||||
| LetRec [(Symbol,IR)] IR
|
||||
| MakeSequence [Z]
|
||||
| ApplyIR IR [Z]
|
||||
| ApplyZ Z [Z] -- call to unknown function
|
||||
| Construct R.Reference ConstructorId [Z]
|
||||
| Request R.Reference ConstructorId [Z]
|
||||
| Handle Z IR
|
||||
| If Z IR IR
|
||||
| And Z IR
|
||||
| Or Z IR
|
||||
| Not Z
|
||||
| Match Z [(Pattern, Maybe IR, IR)] -- pattern, optional guard, rhs
|
||||
-- | Watch Text (Term Symbol) IR
|
||||
deriving (Eq,Show)
|
||||
| Let (IR' z) (IR' z)
|
||||
| LetRec [(Symbol,(IR' z))] (IR' z)
|
||||
| MakeSequence [z]
|
||||
| ApplyIR (IR' z) [z]
|
||||
| ApplyZ z [z] -- call to unknown function
|
||||
| Construct R.Reference ConstructorId [z]
|
||||
| Request R.Reference ConstructorId [z]
|
||||
| Handle z (IR' z)
|
||||
| If z (IR' z) (IR' z)
|
||||
| And z (IR' z)
|
||||
| Or z (IR' z)
|
||||
| Not z
|
||||
| Match z [(Pattern, Maybe (IR' z), (IR' z))] -- pattern, optional guard, rhs
|
||||
deriving (Functor,Foldable,Traversable,Eq,Show)
|
||||
|
||||
-- Contains the effect ref and ctor id, the args, and the continuation
|
||||
-- which expects the result at the top of the stack
|
||||
|
||||
@ -53,8 +53,6 @@ at i (Machine m) = case i of
|
||||
Val v -> v
|
||||
Slot i -> m !! fromIntegral i
|
||||
LazySlot i -> m !! fromIntegral i
|
||||
-- let nonce = 42 -- todo: we need to conjure up a unique id here, using some monad
|
||||
-- in Lazy nonce s (m !! fromIntegral i)
|
||||
|
||||
ati :: Z -> Machine -> Int64
|
||||
ati i m = case at i m of
|
||||
|
||||
@ -1,10 +1,12 @@
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language StrictData #-}
|
||||
{-# Language Strict #-}
|
||||
{-# Language BangPatterns #-}
|
||||
{-# Language LambdaCase #-}
|
||||
|
||||
module Unison.Runtime.Rt1 where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.Foldable (for_)
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
@ -12,36 +14,22 @@ import Data.Text (Text)
|
||||
import Data.Traversable (for)
|
||||
import Data.Word (Word64)
|
||||
import Unison.Runtime.IR
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Data.Vector.Mutable as MV
|
||||
|
||||
data Machine
|
||||
= Machine { stack :: IORef (MV.IOVector V)
|
||||
, supply :: IORef Int }
|
||||
type Stack = MV.IOVector V
|
||||
|
||||
-- An empty machine
|
||||
machine0 :: IO Machine
|
||||
machine0 = do
|
||||
stack <- MV.new 256
|
||||
MV.set stack (T "uninitialized")
|
||||
stackRef <- newIORef stack
|
||||
supply <- newIORef 0
|
||||
pure $ Machine stackRef supply
|
||||
|
||||
push :: Size -> V -> Machine -> IO ()
|
||||
push size v m = do
|
||||
s0 <- readIORef (stack m)
|
||||
push :: Size -> V -> Stack -> IO Stack
|
||||
push size v s0 = do
|
||||
s1 <-
|
||||
if (size >= MV.length s0)
|
||||
then do
|
||||
-- increase the size to fit
|
||||
s1 <- MV.grow s0 size
|
||||
writeIORef (stack m) s1
|
||||
pure s1
|
||||
else pure s0
|
||||
MV.write s1 size v
|
||||
|
||||
fresh :: Machine -> IO Int
|
||||
fresh m = atomicModifyIORef' (supply m) (\n -> (n + 1, n))
|
||||
pure s1
|
||||
|
||||
type Size = Int
|
||||
|
||||
@ -49,38 +37,36 @@ force :: V -> IO V
|
||||
force (Ref _ _ r) = readIORef r >>= force
|
||||
force v = pure v
|
||||
|
||||
at :: Size -> Z -> Machine -> IO V
|
||||
at :: Size -> Z -> Stack -> IO V
|
||||
at size i m = case i of
|
||||
Val v -> force v
|
||||
Slot i -> do
|
||||
s <- readIORef (stack m)
|
||||
Slot i ->
|
||||
-- the top of the stack is slot 0, at index size - 1
|
||||
force =<< MV.read s (size - i - 1)
|
||||
LazySlot i -> do
|
||||
s <- readIORef (stack m)
|
||||
MV.read s (size - i - 1)
|
||||
force =<< MV.read m (size - i - 1)
|
||||
LazySlot i ->
|
||||
MV.read m (size - i - 1)
|
||||
|
||||
ati :: Size -> Z -> Machine -> IO Int64
|
||||
ati :: Size -> Z -> Stack -> IO Int64
|
||||
ati size i m = at size i m >>= \case
|
||||
I i -> pure i
|
||||
_ -> fail "type error"
|
||||
|
||||
atn :: Size -> Z -> Machine -> IO Word64
|
||||
atn :: Size -> Z -> Stack -> IO Word64
|
||||
atn size i m = at size i m >>= \case
|
||||
N i -> pure i
|
||||
_ -> fail "type error"
|
||||
|
||||
atf :: Size -> Z -> Machine -> IO Double
|
||||
atf :: Size -> Z -> Stack -> IO Double
|
||||
atf size i m = at size i m >>= \case
|
||||
F i -> pure i
|
||||
_ -> fail "type error"
|
||||
|
||||
atb :: Size -> Z -> Machine -> IO Bool
|
||||
atb :: Size -> Z -> Stack -> IO Bool
|
||||
atb size i m = at size i m >>= \case
|
||||
B b -> pure b
|
||||
_ -> fail "type error"
|
||||
|
||||
att :: Size -> Z -> Machine -> IO Text
|
||||
att :: Size -> Z -> Stack -> IO Text
|
||||
att size i m = at size i m >>= \case
|
||||
T t -> pure t
|
||||
_ -> fail "type error"
|
||||
@ -94,31 +80,49 @@ arity :: V -> Int
|
||||
arity (Lam n _ _) = n
|
||||
arity _ = 0
|
||||
|
||||
run :: CompilationEnv -> IR -> Machine -> IO Result
|
||||
run env ir m = go 0 ir where
|
||||
go size ir = case ir of
|
||||
If c t f -> atb size c m >>= \case True -> go size t; False -> go size f
|
||||
And i j -> atb size i m >>= \case True -> go size j; False -> done (B False)
|
||||
Or i j -> atb size i m >>= \case True -> done (B True); False -> go size j
|
||||
Not i -> atb size i m >>= (done . B . not)
|
||||
Leaf (Val v) -> done v
|
||||
Leaf s -> done =<< at size s m
|
||||
Let b body -> go size b >>= \case
|
||||
RRequest req -> pure $ RRequest (req `appendCont` body)
|
||||
RDone v -> push size v m >> go (size + 1) body
|
||||
e -> error $ show e
|
||||
LetRec bs body -> letrec size bs body
|
||||
run :: CompilationEnv -> IR -> IO Result
|
||||
run _env ir = do
|
||||
supply <- newIORef 0
|
||||
m0 <- MV.new 256
|
||||
MV.set m0 (T "uninitialized")
|
||||
let
|
||||
fresh :: IO Int
|
||||
fresh = atomicModifyIORef' supply (\n -> (n + 1, n))
|
||||
|
||||
letrec size bs body = do
|
||||
let size' = size + length bs
|
||||
refs <- for bs $ \(v,b) -> do
|
||||
r <- newIORef (N 99)
|
||||
i <- fresh m
|
||||
pure (Ref i v r, b)
|
||||
for_ (refs `zip` [0..]) $ \((r,_), i) -> push (size + i) r m
|
||||
for_ refs $ \(Ref _ _ r,b) -> do
|
||||
let toVal (RDone a) = a
|
||||
toVal e = error ("bindings in a let rec must not have effects " ++ show e)
|
||||
result <- toVal <$> go size' ir
|
||||
writeIORef r result
|
||||
go size' body
|
||||
go :: Size -> Stack -> IR -> IO Result
|
||||
go size m ir = case ir of
|
||||
If c t f -> atb size c m >>= \case
|
||||
True -> go size m t
|
||||
False -> go size m f
|
||||
And i j -> atb size i m >>= \case
|
||||
True -> go size m j
|
||||
False -> done (B False)
|
||||
Or i j -> atb size i m >>= \case
|
||||
True -> done (B True)
|
||||
False -> go size m j
|
||||
Not i -> atb size i m >>= (done . B . not)
|
||||
Leaf (Val v) -> done v
|
||||
Leaf s -> done =<< at size s m
|
||||
Let b body -> go size m b >>= \case
|
||||
RRequest req -> pure $ RRequest (req `appendCont` body)
|
||||
RDone v -> push size v m >>= \m -> go (size + 1) m body
|
||||
e -> error $ show e
|
||||
LetRec bs body -> letrec size m bs body
|
||||
_ -> error $ "TODO - fill in the rest of Rt1.go " <> show ir
|
||||
|
||||
letrec :: Size -> Stack -> [(Symbol, IR)] -> IR -> IO Result
|
||||
letrec size m bs body = do
|
||||
let size' = size + length bs
|
||||
refs <- for bs $ \(v,b) -> do
|
||||
r <- newIORef (N 99)
|
||||
i <- fresh
|
||||
pure (Ref i v r, b)
|
||||
m <- foldM (\m ((r,_), i) -> push (size + i) r m) m (refs `zip` [0..])
|
||||
for_ refs $ \(Ref _ _ r, ir) -> do
|
||||
let toVal (RDone a) = a
|
||||
toVal e = error ("bindings in a let rec must not have effects " ++ show e)
|
||||
result <- toVal <$> go size' m ir
|
||||
writeIORef r result
|
||||
go size' m body
|
||||
|
||||
go 0 m0 ir
|
||||
|
||||
Loading…
Reference in New Issue
Block a user