~jojo/Carth

c46859b9164e588ae2ffdb9aa2399bbd9c54efc6 — JoJo 1 year, 5 months ago c2fce64
Make transmute a builtin virtual instead of a whole AST variant
M src/Check.hs => src/Check.hs +0 -4
@@ 6,7 6,6 @@ import Prelude hiding (span)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Functor
import Data.Bifunctor
import Data.Bitraversable
import Data.Foldable


@@ 174,8 173,6 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        Inferred.Sizeof _t -> pure ()
        Inferred.Deref x -> boundInExpr x
        Inferred.Store x p -> boundInExpr x *> boundInExpr p
        Inferred.Transmute x t u ->
            boundInExpr x *> boundInType pos t *> boundInType pos u
    boundInType :: SrcPos -> Inferred.Type -> Bound
    boundInType pos = \case
        Inferred.TVar tv -> do


@@ 240,4 237,3 @@ compileDecisionTrees tdefs = compDefs
        Inferred.Sizeof t -> pure (Checked.Sizeof t)
        Inferred.Deref x -> fmap Checked.Deref (compExpr x)
        Inferred.Store x p -> liftA2 Checked.Store (compExpr x) (compExpr p)
        Inferred.Transmute x t u -> compExpr x <&> \x' -> Checked.Transmute pos x' t u

M src/Checked.hs => src/Checked.hs +0 -1
@@ 67,7 67,6 @@ data Expr'
    | Deref Expr
    | Store Expr Expr
    | Absurd Type
    | Transmute SrcPos Expr Type Type
    deriving (Show)

data Expr = Expr (Maybe SrcPos) Expr'

M src/Codegen.hs => src/Codegen.hs +0 -58
@@ 257,7 257,6 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Deref e -> genDeref e
        Store x p -> genStore x p
        Absurd t -> fmap (VLocal . undef) (genType t)
        Transmute epos e t u -> genTransmute epos e t u

genExprLambda :: TypedVar -> (Expr, M.Type) -> Gen Val
genExprLambda p (b, bt) = do


@@ 512,63 511,6 @@ genStore x p = do
    emitDo (store x' p'')
    pure p'

genTransmute :: SrcPos -> Expr -> M.Type -> M.Type -> Gen Val
genTransmute pos e t u = do
    t' <- genType t
    u' <- genType u
    st <- lift (sizeof t')
    su <- lift (sizeof u')
    if st == su
        then genExpr e >>= transmute t' u'
        else throwError (TransmuteErr pos (t, st) (u, su))

-- | Assumes that the from-type and to-type are of the same size.
transmute :: Type -> Type -> Val -> Gen Val
transmute t u x = case (t, u) of
    (FunctionType _ _ _, _) -> transmuteIce
    (_, FunctionType _ _ _) -> transmuteIce
    (MetadataType, _) -> transmuteIce
    (_, MetadataType) -> transmuteIce
    (LabelType, _) -> transmuteIce
    (_, LabelType) -> transmuteIce
    (TokenType, _) -> transmuteIce
    (_, TokenType) -> transmuteIce
    (VoidType, _) -> transmuteIce
    (_, VoidType) -> transmuteIce

    (IntegerType _, IntegerType _) -> bitcast'
    (IntegerType _, PointerType _ _) ->
        getLocal x >>= \x' -> emitAnonReg (inttoptr x' u) <&> VLocal
    (IntegerType _, FloatingPointType _) -> bitcast'
    (IntegerType _, VectorType _ _) -> bitcast'

    (PointerType pt _, PointerType pu _) | pt == pu -> pure x
                                         | otherwise -> bitcast'
    (PointerType _ _, IntegerType _) ->
        getLocal x >>= \x' -> emitAnonReg (ptrtoint x' u) <&> VLocal
    (PointerType _ _, _) -> stackCast
    (_, PointerType _ _) -> stackCast

    (FloatingPointType _, FloatingPointType _) -> pure x
    (FloatingPointType _, IntegerType _) -> bitcast'
    (FloatingPointType _, VectorType _ _) -> bitcast'

    (VectorType _ vt, VectorType _ vu) | vt == vu -> pure x
                                       | otherwise -> bitcast'
    (VectorType _ _, IntegerType _) -> bitcast'
    (VectorType _ _, FloatingPointType _) -> bitcast'

    (StructureType _ _, _) -> stackCast
    (_, StructureType _ _) -> stackCast
    (ArrayType _ _, _) -> stackCast
    (_, ArrayType _ _) -> stackCast
    (NamedTypeReference _, _) -> stackCast
    (_, NamedTypeReference _) -> stackCast
  where
    transmuteIce = ice $ "transmute " ++ show t ++ " to " ++ show u
    bitcast' = getLocal x >>= \x' -> emitAnonReg (bitcast x' u) <&> VLocal
    stackCast = getVar x >>= \x' -> emitAnonReg (bitcast x' (LLType.ptr u)) <&> VVar

genStrEq :: Val -> Val -> Gen Val
genStrEq s1 s2 = do
    s1' <- getLocal s1

M src/Gen.hs => src/Gen.hs +63 -0
@@ 465,10 465,12 @@ lookupVar' x = do
genAppBuiltinVirtual :: TypedVar -> [Gen Val] -> Gen Val
genAppBuiltinVirtual (TypedVar g t) aes = do
    as <- sequence aes
    pos <- view srcPos
    let wrap xts genRt f = do
            rt' <- genRt
            genWrapInLambdas rt' [] (drop (length as) xts)
                $ \bes -> mapM lookupVar bes >>= \bs -> f (as ++ bs)
    let wrap1 (xt, rt, f) = wrap [xt] rt (\xs -> f (xs !! 0))
    let wrap2 (xt, rt, f) = wrap [xt, xt] rt (\xs -> f (xs !! 0) (xs !! 1))
    case g of
        "+" -> wrap2 $ arithm add add fadd t


@@ 490,6 492,11 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
        ">=" -> wrap2 $ rel LLIPred.UGE LLIPred.SGE LLFPred.OGE t
        "<" -> wrap2 $ rel LLIPred.ULT LLIPred.SLT LLFPred.OLT t
        "<=" -> wrap2 $ rel LLIPred.ULE LLIPred.SLE LLFPred.OLE t
        "transmute" -> wrap1 $ case t of
            M.TFun a b -> case pos of
                Just p -> (a, genType b, \x -> genTransmute p x a b)
                Nothing -> ice "genAppBuiltinVirtual: transmute: srcPos is Nothing"
            _ -> noInst
        _ -> ice $ "genAppBuiltinVirtual: No builtin virtual function `" ++ g ++ "`"
  where
    arithm u s f = \case


@@ 524,6 531,15 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
                        else liftA2 (fcmp f) (getLocal x) (getLocal y)
            )
        _ -> noInst
    genTransmute :: SrcPos -> Val -> M.Type -> M.Type -> Gen Val
    genTransmute pos x a b = do
        a' <- genType a
        b' <- genType b
        sa <- lift (sizeof a')
        sb <- lift (sizeof b')
        if sa == sb
            then transmute a' b' x
            else throwError (TransmuteErr pos (a, sa) (b, sb))
    isNat = \case
        TNat8 -> True
        TNat16 -> True


@@ 539,6 555,53 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
    noInst =
        ice $ "No instance of builtin virtual function " ++ g ++ " for type " ++ pretty t

-- | Assumes that the from-type and to-type are of the same size.
transmute :: Type -> Type -> Val -> Gen Val
transmute t u x = case (t, u) of
    (FunctionType _ _ _, _) -> transmuteIce
    (_, FunctionType _ _ _) -> transmuteIce
    (MetadataType, _) -> transmuteIce
    (_, MetadataType) -> transmuteIce
    (LabelType, _) -> transmuteIce
    (_, LabelType) -> transmuteIce
    (TokenType, _) -> transmuteIce
    (_, TokenType) -> transmuteIce
    (VoidType, _) -> transmuteIce
    (_, VoidType) -> transmuteIce

    (IntegerType _, IntegerType _) -> bitcast'
    (IntegerType _, PointerType _ _) ->
        getLocal x >>= \x' -> emitAnonReg (inttoptr x' u) <&> VLocal
    (IntegerType _, FloatingPointType _) -> bitcast'
    (IntegerType _, VectorType _ _) -> bitcast'

    (PointerType pt _, PointerType pu _) | pt == pu -> pure x
                                         | otherwise -> bitcast'
    (PointerType _ _, IntegerType _) ->
        getLocal x >>= \x' -> emitAnonReg (ptrtoint x' u) <&> VLocal
    (PointerType _ _, _) -> stackCast
    (_, PointerType _ _) -> stackCast

    (FloatingPointType _, FloatingPointType _) -> pure x
    (FloatingPointType _, IntegerType _) -> bitcast'
    (FloatingPointType _, VectorType _ _) -> bitcast'

    (VectorType _ vt, VectorType _ vu) | vt == vu -> pure x
                                       | otherwise -> bitcast'
    (VectorType _ _, IntegerType _) -> bitcast'
    (VectorType _ _, FloatingPointType _) -> bitcast'

    (StructureType _ _, _) -> stackCast
    (_, StructureType _ _) -> stackCast
    (ArrayType _ _, _) -> stackCast
    (_, ArrayType _ _) -> stackCast
    (NamedTypeReference _, _) -> stackCast
    (_, NamedTypeReference _) -> stackCast
  where
    transmuteIce = ice $ "transmute " ++ show t ++ " to " ++ show u
    bitcast' = getLocal x >>= \x' -> emitAnonReg (bitcast x' u) <&> VLocal
    stackCast = getVar x >>= \x' -> emitAnonReg (bitcast x' (LLType.ptr u)) <&> VVar

callBuiltin :: String -> [Operand] -> Gen FunInstr
callBuiltin f as = do
    (_, rt) <- view (builtins . to (Map.lookup f)) <&> \case

M src/Infer.hs => src/Infer.hs +0 -3
@@ 8,7 8,6 @@ import Control.Applicative hiding (Const(..))
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Functor
import Data.Bifunctor
import Data.Graph (SCC(..), stronglyConnComp)
import qualified Data.Map.Strict as Map


@@ 229,8 228,6 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        unify (Expected (TBox tx)) (Found (getPos p) tp)
        pure (tp, Store x' p')

    Parsed.Transmute x -> fresh >>= \u -> infer x <&> \(t, x') -> (u, Transmute x' t u)

inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, FunMatch)
inferFunMatch cases = do
    tpat <- fresh

M src/Inferred.hs => src/Inferred.hs +5 -2
@@ 97,7 97,6 @@ data Expr'
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Transmute Expr Type Type
    deriving Show

type Expr = WithPos Expr'


@@ 133,8 132,11 @@ builtinExterns = Map.fromList $ map

builtinVirtuals :: Map String Scheme
builtinVirtuals =
    let tva = TVExplicit (Parsed.Id (WithPos (SrcPos "<builtin>" 0 0) "a"))
    let tv a = TVExplicit (Parsed.Id (WithPos (SrcPos "<builtin>" 0 0) a))
        tva = tv "a"
        ta = TVar tva
        tvb = tv "b"
        tb = TVar tvb
        arithScm = Forall (Set.fromList [tva]) (TFun ta (TFun ta ta))
        bitwiseScm = arithScm
        relScm = Forall (Set.fromList [tva]) (TFun ta (TFun ta tBool))


@@ 155,6 157,7 @@ builtinVirtuals =
              , (">=", relScm)
              , ("<", relScm)
              , ("<=", relScm)
              , ("transmute", Forall (Set.fromList [tva, tvb]) (TFun ta tb))
              ]

defSigs :: Def -> [(String, Scheme)]

M src/Monomorphic.hs => src/Monomorphic.hs +0 -2
@@ 62,7 62,6 @@ data Expr'
    | Deref Expr
    | Store Expr Expr
    | Absurd Type
    | Transmute SrcPos Expr Type Type
    deriving (Show)

data Expr = Expr (Maybe SrcPos) Expr'


@@ 105,7 104,6 @@ fvExpr' = \case
    Deref e -> freeVars e
    Store x p -> Set.union (freeVars x) (freeVars p)
    Absurd _ -> Set.empty
    Transmute _ x _ _ -> freeVars x

fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case

M src/Monomorphize.hs => src/Monomorphize.hs +0 -2
@@ 105,8 105,6 @@ mono (Checked.Expr pos ex) = fmap (Expr pos) $ case ex of
    Checked.Deref x -> fmap Deref (mono x)
    Checked.Store x p -> liftA2 Store (mono x) (mono p)
    Checked.Absurd t -> fmap Absurd (monotype t)
    Checked.Transmute xpos x t u ->
        liftA3 (Transmute xpos) (mono x) (monotype t) (monotype u)

monoFun :: Checked.Fun -> Mono Fun
monoFun ((p, tp), (b, bt)) = do

M src/Parse.hs => src/Parse.hs +0 -3
@@ 193,7 193,6 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
        , sizeof
        , deref
        , store
        , transmute
        , app
        ]
    funMatch = reserved "fmatch" *> fmap FunMatch cases


@@ 247,7 246,6 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
    sizeof = reserved "sizeof" *> fmap Sizeof type_
    deref = reserved "deref" *> fmap Deref expr
    store = reserved "store" *> liftA2 Store expr expr
    transmute = reserved "transmute" *> fmap Transmute expr
    app = do
        rator <- expr
        rands <- some expr


@@ 404,7 402,6 @@ reserveds =
    , "sizeof"
    , "deref"
    , "store"
    , "transmute"
    , "import"
    , "case"
    , "id@"

M src/Parsed.hs => src/Parsed.hs +0 -2
@@ 78,7 78,6 @@ data Expr'
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Transmute Expr
    deriving (Show, Eq)

type Expr = WithPos Expr'


@@ 138,7 137,6 @@ fvExpr = unpos >>> \case
    Sizeof _t -> Set.empty
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)
    Transmute e -> fvExpr e

fvMatch :: Expr -> [(Pat, Expr)] -> Set (Id 'Small)
fvMatch e cs = Set.union (freeVars e) (fvCases cs)

M src/Pretty.hs => src/Pretty.hs +0 -1
@@ 130,7 130,6 @@ prettyExpr' d = \case
    Parsed.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]
    Parsed.Store x p -> concat
        ["(store " ++ pretty' (d + 7) x, indent (d + 7) ++ pretty' (d + 7) p ++ ")"]
    Parsed.Transmute e -> concat ["(transmute ", pretty' (d + 11) e, ")"]

prettyDef :: Int -> Parsed.Def -> String
prettyDef d' = \case

M src/Subst.hs => src/Subst.hs +0 -1
@@ 36,7 36,6 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    Sizeof t -> Sizeof (subst s t)
    Deref e -> Deref (substExpr s e)
    Store x p -> Store (substExpr s x) (substExpr s p)
    Transmute e t u -> Transmute (substExpr s e) (subst s t) (subst s u)

substFunMatch :: Subst -> FunMatch -> FunMatch
substFunMatch s (cs, tp, tb) = ((substCases s cs), (subst s tp), (subst s tb))