Copy constructors and destructors

new/common.ktn

@@ -1,7 +1,7 @@
 vocab kitten {
 
   intrinsic call<R..., S...> (R..., (R... -> S...) -> S...)
-  intrinsic drop<A> (A ->)
+  intrinsic forget<A> (A ->)
   intrinsic swap<A, B> (A, B -> B, A)
 
 }
@@ -19,65 +19,106 @@ about call:
     new state 'S...'.
     """
 
+trait copy<T> (T -> T)
+
+about copy:
+  docs: """
+    Copy constructor, implicitly called for every mention of a local variable
+    after the first. To make a type implicitly copyable without any additional
+    logic, simply write an instance with an empty body. Types that don't
+    implement this trait can only be moved.
+    """
+
+trait destroy<T> (T -> T)
+
+about destroy:
+  docs: """
+    Destructor, implicitly called when a local variable goes out of scope, or
+    when a value is explicitly dropped with `-> _;`. Types that don't implement
+    this trait can't be dropped.
+    """
+
 type Int8 {}
 
+instance copy (Int8 -> Int8) {}
+
 about type Int8:
   size: 1
   alignment: 1
 
 type Int16 {}
 
+instance copy (Int16 -> Int16) {}
+
 about type Int16:
   size: 2
   alignment: 2
 
 type Int32 {}
 
+instance copy (Int32 -> Int32) {}
+
 about type Int32:
   size: 4
   alignment: 4
 
 type Int64 {}
 
+instance copy (Int64 -> Int64) {}
+
 about type Int64:
   size: 8
   alignment: 8
 
 type UInt8 {}
 
+instance copy (UInt8 -> UInt8) {}
+
 about type UInt8:
   size: 1
   alignment: 1
 
 type UInt16 {}
 
+instance copy (UInt16 -> UInt16) {}
+
 about type UInt16:
   size: 2
   alignment: 2
 
 type UInt32 {}
 
+instance copy (UInt32 -> UInt32) {}
+
 about type UInt32:
   size: 4
   alignment: 4
 
 type UInt64 {}
 
+instance copy (UInt64 -> UInt64) {}
+
 about type UInt64:
   size: 8
   alignment: 8
 
 type Char:
   case _char (UInt32)
 
+instance copy (Char -> Char) {}
+
 type Float32 {}
 
+instance copy (Float32 -> Float32) {}
+
 about type Float32:
   size: 4
   alignment: 4
 
 type Float64 {}
 
+instance copy (Float64 -> Float64) {}
+
 about type Float64:
   size: 8
   alignment: 8
@@ -465,6 +506,8 @@ type Bool:
   case false
   case true
 
+instance copy (Bool -> Bool) {}
+
 define not (Bool -> Bool):
   if:
     false
@@ -563,6 +606,8 @@ type Optional<T>:
   case none
   case some (T)
 
+// instance copy<T> (Optional<T> -> Optional<T>) where (copy<T>) {}
+
 define from_optional<T> (Optional<T>, T -> T):
   -> default;
   match
@@ -604,6 +649,8 @@ define optional<R..., S..., A>
 type Pair<A, B>:
   case pair (A, B)
 
+// instance copy<A, B> (Pair<A, B> -> Pair<A, B>) where (copy<A>, copy<B>) {}
+
 define unpair<A, B> (Pair<A, B> -> A, B):
   match case pair {}
 
@@ -616,6 +663,8 @@ type Either<A, B>:
   case left (A)
   case right (B)
 
+// instance copy<A, B> (Either<A, B> -> Either<A, B>) where (copy<A>, copy<B>) {}
+
 define from_left<A, B> (Either<A, B> -> A +Fail):
   match
   case left {}
@@ -684,6 +733,8 @@ define map_right<A, B, C> (Either<A, B>, (B -> C) -> Either<A, C>):
 type Pointer<T>:
   case _pointer (UInt64)
 
+// instance copy<T> (Pointer<T> -> Pointer<T>) {}
+
 // do (until) { ... }
 define until<R...> (R..., (R... -> R..., Bool) -> R...):
   -> f;
@@ -699,6 +750,8 @@ define while<R...> (R..., (R... -> R..., Bool) -> R...):
 type List<T>:
   case _list (Pointer<T>, Pointer<T>, Pointer<T>)
 
+// instance copy<T> (List<T> -> List<T>) where (copy<T>)
+
 vocab kitten {
 
   intrinsic empty<T> (List<T> -> Bool)
@@ -1055,6 +1108,8 @@ vocab kitten {
 type RGBA:
   case rgba (UInt8, UInt8, UInt8, UInt8)
 
+instance copy (RGBA -> RGBA) {}
+
 define draw (List<List<RGBA>> -> +IO):
   _::kitten::draw
 

new/lib/Kitten/Enter.hs

@@ -25,6 +25,7 @@ import Kitten.Fragment (Fragment)
 import Kitten.Infer (mangleInstance, typecheck)
 import Kitten.Informer (checkpoint, report)
 import Kitten.Instantiated (Instantiated(Instantiated))
+import Kitten.Linearize (linearize)
 import Kitten.Metadata (Metadata)
 import Kitten.Monad (K)
 import Kitten.Name
@@ -358,8 +359,12 @@ resolveAndDesugar dictionary definition = do
   postfix <- Infix.desugar dictionary resolved
   checkpoint
 
--- In addition, now that we know which names refer to local variables,
--- quotations can be rewritten into closures that explicitly capture the
--- variables they use from the enclosing scope.
+-- In addition, now that we know which names refer to local variables, we can:
+--
+--   * Rewrite quotations into closures that explicitly capture the variables
+--     they use from the enclosing scope.
+--
+--   * Insert implicit calls to copy constructors and destructors.
 
-  return postfix { Definition.body = scope $ Definition.body postfix }
+  return postfix
+    { Definition.body = linearize $ scope $ Definition.body postfix }

new/lib/Kitten/Interpret.hs

@@ -199,7 +199,7 @@ interpret dictionary mName mainArgs stdin' stdout' _stderr' initialStack = do
 
       "call" -> call
 
-      "drop" -> modifyIORef' stackRef tail
+      "forget" -> modifyIORef' stackRef tail
 
       "swap" -> do
         (a : b : r) <- readIORef stackRef

new/lib/Kitten/Linearize.hs

@@ -16,59 +16,64 @@ module Kitten.Linearize
 
 import Control.Arrow (first)
 import Data.List (transpose)
-import Kitten.Name (GeneralName(..), LocalIndex(..), Qualified(..))
+import Kitten.Name (Closed(..), ClosureIndex(..), LocalIndex(..))
+import Kitten.Name (GeneralName(..), Qualified(..))
 import Kitten.Origin (Origin)
 import Kitten.Term (Case(..), Else(..), Term(..), Value(..))
-import Kitten.Type (Type)
 import qualified Kitten.Operator as Operator
 import qualified Kitten.Term as Term
 import qualified Kitten.Vocabulary as Vocabulary
 
--- | Linearization replaces all copies and drops with explicit invocations of
--- the @_::copy@ and @_::drop@ words. A value is copied if it appears twice or
--- more in its scope; it's dropped if it doesn't appear at all, or if an
--- explicit @drop@ is present due to an ignored local (@_@). If it only appears
--- once, it is moved, and no special word is invoked.
+import Debug.Trace (trace)
+import Text.PrettyPrint.HughesPJClass (Pretty(..))
+import qualified Text.PrettyPrint as Pretty
+
+-- | Linearization (I didn't know what else to call it) instruments copies and
+-- drops of local variables with invocations of @_::copy@ (copy constructor) and
+-- @_::destroy@ (destructor), respectively.
 --
--- FIXME: This is experimental and subject to change.
+-- A variable is copied if it appears twice or more in its scope; it's dropped
+-- if it doesn't appear at all, or if an explicit drop is present due to an
+-- ignored local (@_@). The first appearance of a local is moved, not copied, so
+-- this doesn't instrument anything if the variable is used only once.
 
-linearize :: Term Type -> Term Type
-linearize = snd . go []
+linearize :: Term () -> Term ()
+linearize = (\x -> trace (Pretty.render $ pPrint x) x) . snd . go []
   where
 
-  go :: [Int] -> Term Type -> ([Int], Term Type)
+  go :: [Int] -> Term () -> ([Int], Term ())
   go counts0 term = case term of
     Coercion{} -> (counts0, term)
-    Compose type_ a b -> let
+    Compose _ a b -> let
       (counts1, a') = go counts0 a
       (counts2, b') = go counts1 b
-      in (counts2, Compose type_ a' b')
+      in (counts2, Compose () a' b')
     Generic x body origin -> let
       (counts1, body') = go counts0 body
       in (counts1, Generic x body' origin)
     Group{} -> error "group should not appear after desugaring"
-    Lambda type_ x varType body origin -> let
+    Lambda _ x varType body origin -> let
       (n : counts1, body') = go (0 : counts0) body
       body'' = case n of
-        0 -> instrumentDrop origin varType body'
+        0 -> instrumentDrop origin body'
         1 -> body'
-        _ -> instrumentCopy varType body'
-      in (counts1, Lambda type_ x varType body'' origin)
-    -- FIXME: count usages for each branch & take maximum
-    Match hint type_ cases else_ origin -> let
+        _ -> instrumentCopy body'
+      in (counts1, Lambda () x varType body'' origin)
+    -- FIXME: count usages for each branch & take maximum?
+    Match hint _ cases else_ origin -> let
 
       (counts1, mElse') = goElse counts0 else_
       (counts2, cases') = first (map maximum . transpose)
         $ unzip $ map (goCase counts0) cases
-      in (zipWith max counts1 counts2, Match hint type_ cases' mElse' origin)
+      in (zipWith max counts1 counts2, Match hint () cases' mElse' origin)
       where
 
-      goCase :: [Int] -> Case Type -> ([Int], Case Type)
+      goCase :: [Int] -> Case () -> ([Int], Case ())
       goCase counts (Case name body caseOrigin) = let
         (counts1, body') = go counts body
         in (counts1, Case name body' caseOrigin)
 
-      goElse :: [Int] -> Else Type -> ([Int], Else Type)
+      goElse :: [Int] -> Else () -> ([Int], Else ())
       goElse counts (Else body elseOrigin) = let
         (counts1, body') = go counts body
         in (counts1, Else body' elseOrigin)
@@ -79,52 +84,56 @@ linearize = snd . go []
     Push _ (Local (LocalIndex index)) _ -> let
       (h, t : ts) = splitAt index counts0
       in (h ++ succ t : ts, term)
-    Push _ Capture{} _ -> error
-      "pushing of capture should not appear after desugaring"
+    Push _ (Capture closed body) origin -> let
+      go (ClosedLocal (LocalIndex index)) acc = let
+        (h, t : ts) = splitAt index acc
+        in h ++ succ t : ts
+      go (ClosedClosure (ClosureIndex index)) acc
+        = acc  -- TODO: count closure variables (maybe by rewriting them into locals)
+      in (foldr go counts0 closed, term)
+{-
     Push _ Quotation{} _ -> error
       "pushing of quotation should not appear after desugaring"
+-}
     Push{} -> (counts0, term)
     Word{} -> (counts0, term)
 
-instrumentDrop :: Origin -> Type -> Term Type -> Term Type
-instrumentDrop origin type_ a = Term.compose todoTyped origin
+instrumentDrop :: Origin -> Term () -> Term ()
+instrumentDrop origin a = Term.compose () origin
   [ a
-  , Push todoTyped (Local (LocalIndex 0)) origin
-  , Word todoTyped Operator.Postfix
-    (QualifiedName (Qualified Vocabulary.global "drop")) [type_] origin
+  , Push () (Local (LocalIndex 0)) origin
+  , Word () Operator.Postfix
+    (QualifiedName (Qualified Vocabulary.global "destroy")) [] origin
   ]
 
-instrumentCopy :: Type -> Term Type -> Term Type
-instrumentCopy varType = go 0
+instrumentCopy :: Term () -> Term ()
+instrumentCopy = go 0
   where
 
-  go :: Int -> Term Type -> Term Type
+  go :: Int -> Term () -> Term ()
   go n term = case term of
     Coercion{} -> term
-    Compose type_ a b -> Compose type_ (go n a) (go n b)
+    Compose _ a b -> Compose () (go n a) (go n b)
     Generic x body origin -> Generic x (go n body) origin
     Group{} -> error "group should not appear after desugaring"
-    Lambda type_ name varType' body origin
-      -> Lambda type_ name varType' (go (succ n) body) origin
-    Match hint type_ cases else_ origin
-      -> Match hint type_ (map goCase cases) (goElse else_) origin
+    Lambda _ name varType body origin
+      -> Lambda () name varType (go (succ n) body) origin
+    Match hint _ cases else_ origin
+      -> Match hint () (map goCase cases) (goElse else_) origin
       where
 
-      goCase :: Case Type -> Case Type
+      goCase :: Case () -> Case ()
       goCase (Case name body caseOrigin) = Case name (go n body) caseOrigin
 
-      goElse :: Else Type -> Else Type
+      goElse :: Else () -> Else ()
       goElse (Else body elseOrigin) = Else (go n body) elseOrigin
 
     New{} -> term
     NewClosure{} -> term
     NewVector{} -> term
     Push _ (Local (LocalIndex index)) origin
       | index == n
-      -> Compose todoTyped term $ Word todoTyped Operator.Postfix
-        (QualifiedName (Qualified Vocabulary.global "copy")) [varType] origin
+      -> Compose () term $ Word () Operator.Postfix
+        (QualifiedName (Qualified Vocabulary.global "copy")) [] origin
     Push{} -> term
     Word{} -> term
-
-todoTyped :: a
-todoTyped = error "TODO: generate typed terms"

new/lib/Kitten/Parse.hs

@@ -738,8 +738,13 @@ blockLikeParser = blockParser <|> blockLambdaParser
 makeLambda :: [(Maybe Unqualified, Origin)] -> Term () -> Origin -> Term ()
 makeLambda parsed body origin = foldr
   (\ (nameMaybe, nameOrigin) acc -> maybe
-    (Compose () (Word () Operator.Postfix
-      (QualifiedName (Qualified Vocabulary.intrinsic "drop")) [] origin) acc)
+    (Term.compose () origin
+      [ Word () Operator.Postfix
+        (QualifiedName (Qualified Vocabulary.global "destroy")) [] origin
+      , Word () Operator.Postfix
+        (QualifiedName (Qualified Vocabulary.intrinsic "forget")) [] origin
+      , acc
+      ])
     (\ name -> Lambda () name () acc nameOrigin)
     nameMaybe)
   body