From 643bf235f06450522116eecc9422afa4ab2efd9c Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 20 Feb 2019 17:20:10 -0500 Subject: [PATCH] executed Hello, World almost exclusively --- .../src/Unison/PrettyPrintEnv.hs | 6 ++++ parser-typechecker/src/Unison/Reference.hs | 2 +- parser-typechecker/src/Unison/Runtime/IR.hs | 30 +++++++++++----- parser-typechecker/src/Unison/Runtime/Rt1.hs | 35 +++++++++++++------ 4 files changed, 53 insertions(+), 20 deletions(-) diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index 1e458c0f2..d5c19f4fd 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -60,3 +60,9 @@ patternName env r cid = case terms env (Referent.Con r cid) of Just name -> name Nothing -> HQ.fromReferent (Referent.Con r cid) + +instance Monoid PrettyPrintEnv where + mempty = PrettyPrintEnv (const Nothing) (const Nothing) + mappend = unionLeft +instance Semigroup PrettyPrintEnv where + (<>) = mappend diff --git a/parser-typechecker/src/Unison/Reference.hs b/parser-typechecker/src/Unison/Reference.hs index 8cdb6bf65..e383cc44c 100644 --- a/parser-typechecker/src/Unison/Reference.hs +++ b/parser-typechecker/src/Unison/Reference.hs @@ -59,7 +59,7 @@ data Id = Id H.Hash Pos Size deriving (Eq,Ord,Generic) instance Show Id where show = addDot . splitSuffix where - addDot (h, s) = show h <> maybe "" ("."<>) s + addDot (h, s) = (take 5 $ show h) <> maybe "" ("."<>) s showShort :: Int -> Reference -> String showShort numHashChars r = diff --git a/parser-typechecker/src/Unison/Runtime/IR.hs b/parser-typechecker/src/Unison/Runtime/IR.hs index d0ebeddd7..aa543da97 100644 --- a/parser-typechecker/src/Unison/Runtime/IR.hs +++ b/parser-typechecker/src/Unison/Runtime/IR.hs @@ -7,10 +7,10 @@ {-# Language PartialTypeSignatures #-} {-# Language StrictData #-} {-# Language TupleSections #-} +{-# Language ViewPatterns #-} module Unison.Runtime.IR where -import Control.Applicative import Data.Foldable import Data.Functor (void) import Data.IORef @@ -40,8 +40,14 @@ type ConstructorId = Int type Term v = AnnotatedTerm v () data CompilationEnv e - = CompilationEnv { toIR :: R.Reference -> Maybe (IR e) - , constructorArity :: R.Reference -> Int -> Maybe Int } + = CompilationEnv { toIR' :: Map R.Reference (IR e) + , constructorArity' :: Map (R.Reference, Int) Int } + +toIR :: CompilationEnv e -> R.Reference -> Maybe (IR e) +toIR = flip Map.lookup . toIR' + +constructorArity :: CompilationEnv e -> R.Reference -> Int -> Maybe Int +constructorArity e r i = Map.lookup (r,i) $ constructorArity' e data SymbolC = SymbolC { isLazy :: Bool @@ -188,6 +194,10 @@ compile0 env bound t = fvs = freeVars bound t go t = case t of Term.Nat' n -> Leaf . Val . N $ n + Term.Int' n -> Leaf . Val . I $ n + Term.Float' n -> Leaf . Val . F $ n + Term.Boolean' n -> Leaf . Val . B $ n + Term.Text' n -> Leaf . Val . T $ n Term.And' x y -> And (ind "and" t x) (go y) Term.LamsNamed' vs body -> Leaf . Val $ Lam (length vs) @@ -204,6 +214,7 @@ compile0 env bound t = Term.Ann' e _ -> go e Term.Match' scrutinee cases -> Match (ind "match" t scrutinee) (compileCase <$> cases) Term.Var' _ -> Leaf $ ind "var" t t + Term.Ref' (toIR env -> Just ir) -> ir _ -> error $ "TODO - don't know how to compile " ++ show t where compileVar _ v [] = unknown v @@ -220,7 +231,8 @@ compile0 env bound t = -> R.Reference -> Int -> IR e ctorIR con src r cid = case constructorArity env r cid of Nothing -> error $ "the compilation env is missing info about how " - ++ "to compile this constructor: " ++ show (r, cid) + ++ "to compile this constructor: " ++ show (r, cid) ++ "\n" ++ show (constructorArity' env) + Just 0 -> con r cid [] Just arity -> Leaf . Val $ Lam arity (FormClosure $ src r cid) ir where -- if `arity` is 1, then `Slot 0` is the sole argument. @@ -395,7 +407,7 @@ instance Show e => Show (Value e) where show (N n) = show n show (B b) = show b show (T t) = show t - show (Lam n e ir) = "(Lam " <> show n <> " " <> show e <> " " <> show ir <> ")" + show (Lam n e ir) = "(Lam " <> show n <> " " <> show e <> " (" <> show ir <> "))" show (Data r cid vs) = "(Data " <> show r <> " " <> show cid <> " " <> show vs <> ")" show (Sequence vs) = "[" <> intercalateMap ", " show vs <> "]" show (Ref n s _) = "(Ref " <> show n <> " " <> show s <> ")" @@ -406,12 +418,12 @@ instance Show e => Show (Value e) where "(LetRecBomb " <> show b <> " in " <> show (fst <$> bs)<> ")" compilationEnv0 :: CompilationEnv e -compilationEnv0 = mempty { toIR = \r -> Map.lookup r builtins } +compilationEnv0 = CompilationEnv builtins mempty instance Semigroup (CompilationEnv e) where (<>) = mappend instance Monoid (CompilationEnv e) where - mempty = CompilationEnv (const Nothing) (\_ _ -> Nothing) + mempty = CompilationEnv mempty mempty mappend c1 c2 = CompilationEnv ir ctor where - ir r = toIR c1 r <|> toIR c2 r - ctor r cid = constructorArity c1 r cid <|> constructorArity c2 r cid + ir = toIR' c1 <> toIR' c2 + ctor = constructorArity' c1 <> constructorArity' c2 diff --git a/parser-typechecker/src/Unison/Runtime/Rt1.hs b/parser-typechecker/src/Unison/Runtime/Rt1.hs index 29e50dc4c..57253e776 100644 --- a/parser-typechecker/src/Unison/Runtime/Rt1.hs +++ b/parser-typechecker/src/Unison/Runtime/Rt1.hs @@ -32,6 +32,9 @@ import Unison.Runtime.IR (pattern CompilationEnv, pattern Req) import Unison.Runtime.IR hiding (CompilationEnv, IR, Req, Value, Z) import qualified Unison.Runtime.IR as IR import Unison.Symbol (Symbol) +import Unison.TermPrinter (prettyTop) +import qualified Unison.Util.Pretty as Pretty +import Debug.Trace type CompilationEnv = IR.CompilationEnv ExternalFunction type IR = IR.IR ExternalFunction @@ -51,6 +54,7 @@ runtime = Runtime terminate eval changeVar term = Term.vmap IR.underlyingSymbol term eval :: (MonadIO m, Monoid a) => CL.CodeLookup m Symbol a -> Term.AnnotatedTerm Symbol a -> m (Term Symbol) eval cl term = do + liftIO . putStrLn $ Pretty.render 80 (prettyTop mempty term) cenv <- compilationEnv cl term -- in `m` RDone result <- liftIO $ run cenv (compile cenv $ Term.amap (const ()) term) @@ -126,6 +130,11 @@ pushMany size values m = do length <- foldM pushArg 0 values pure ((size + length), m) + + -- [s3,s2,s1,s0] [i1,i2,i3] + -- [s3,s2,s1,s0, i1,i2,i3] + -- [s3,s2,s1,s0, i3,i2,i1] + pushManyZ :: Foldable f => Size -> f Z -> Stack -> IO (Size, Stack) pushManyZ size zs m = do m <- ensureSize (size + length zs) m @@ -133,8 +142,8 @@ pushManyZ size zs m = do val <- at size z m -- variable lookup uses current size MV.write m size' val pure (size' + 1) - length <- foldM pushArg 0 zs - pure ((size + length), m) + size2 <- foldM pushArg size zs + pure (size2, m) ensureSize :: Size -> Stack -> IO Stack ensureSize size m = @@ -169,20 +178,22 @@ compilationEnv :: Monad m compilationEnv env t = do let typeDeps = Term.referencedDataDeclarations t <> Term.referencedEffectDeclarations t + traceM "typeDeps" + traceShowM typeDeps arityMap <- fmap (Map.fromList . join) . for (toList typeDeps) $ \case r@(R.DerivedId id) -> do decl <- CL.getTypeDeclaration env id case decl of - Nothing -> pure [] + Nothing -> error $ "no type declaration for " <> show id -- pure [] Just (Left ad) -> pure $ let arities = DD.constructorArities $ DD.toDataDecl ad - in [ ((r, i), arity) | (i, arity) <- arities `zip` [0..] ] + in [ ((r, i), arity) | (arity, i) <- arities `zip` [0..] ] Just (Right dd) -> pure $ let arities = DD.constructorArities dd - in [ ((r, i), arity) | (i, arity) <- arities `zip` [0..] ] + in [ ((r, i), arity) | (arity, i) <- arities `zip` [0..] ] _ -> pure [] - let cenv = CompilationEnv (const Nothing) - (\r cid -> Map.lookup (r,cid) arityMap) + let cenv = CompilationEnv mempty arityMap + -- deps = Term.dependencies t -- this would rely on haskell laziness for compilation, needs more thought --compiledTerms <- fmap (Map.fromList . join) . for (toList deps) $ \case @@ -196,8 +207,7 @@ compilationEnv env t = do builtinCompilationEnv :: CompilationEnv builtinCompilationEnv = - CompilationEnv (flip Map.lookup (builtinsMap <> IR.builtins)) - (\_ _ -> Nothing) + CompilationEnv (builtinsMap <> IR.builtins) mempty where builtins :: [(Text, Int, Size -> Stack -> IO Value)] builtins = [ ("Text.++", 2, \size stack -> do @@ -232,7 +242,12 @@ run env ir = do fresh = atomicModifyIORef' supply (\n -> (n + 1, n)) go :: Size -> Stack -> IR -> IO Result - go size m ir = case ir of + go size m ir = do + stackStuff <- traverse (MV.read m) [0..size-1] + traceM $ "stack: " <> show stackStuff + traceM $ "ir: " <> show ir + traceM "" + case ir of Leaf (Val v) -> done v Leaf slot -> done =<< at size slot m If c t f -> atb size c m >>= \case