aboutsummaryrefslogtreecommitdiff
path: root/Sil
diff options
context:
space:
mode:
Diffstat (limited to 'Sil')
-rw-r--r--Sil/Compile.icl69
-rw-r--r--Sil/Error.dcl2
-rw-r--r--Sil/Error.icl2
-rw-r--r--Sil/Parse.dcl3
-rw-r--r--Sil/Parse.icl29
-rw-r--r--Sil/Syntax.dcl4
-rw-r--r--Sil/Syntax.icl6
-rw-r--r--Sil/Types.dcl1
-rw-r--r--Sil/Types.icl29
9 files changed, 127 insertions, 18 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index e342a66..de3f47f 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -42,13 +42,18 @@ where
censor` = opt o filter isUseful
opt :: 'ABC'.Assembler -> 'ABC'.Assembler
+ // Equality checks for integers
opt ['ABC'.PushI i:'ABC'.Push_b l:'ABC'.EqI:ss] = ['ABC'.EqI_b i (l-1):opt ss]
opt ['ABC'.Push_b l:'ABC'.PushI i:'ABC'.EqI:ss] = ['ABC'.EqI_b i l :opt ss]
+ // Delay pushing if we need to pop
opt ['ABC'.PushI i:'ABC'.Update_b 0 l:'ABC'.Pop_b n:ss] | l == n = ['ABC'.Pop_b n:'ABC'.PushI i:opt ss]
+ // Combine pops
opt ['ABC'.Pop_a i:'ABC'.Pop_a j:ss] = opt ['ABC'.Pop_a (i+j):ss]
opt ['ABC'.Pop_b i:'ABC'.Pop_b j:ss] = opt ['ABC'.Pop_b (i+j):ss]
+ // Remove unreachable code
opt ['ABC'.Rtn:ss] = ['ABC'.Rtn:opt $ skipUntilEntryPoint ss]
opt ['ABC'.Jmp l:ss] = ['ABC'.Jmp l:opt $ skipUntilEntryPoint ss]
+ // Base cases
opt [s:ss] = [s:opt ss]
opt [] = []
@@ -61,7 +66,7 @@ where
isUseful _ = True
skipUntilEntryPoint :: 'ABC'.Assembler -> 'ABC'.Assembler
- skipUntilEntryPoint ss
+ skipUntilEntryPoint ss=:[_:_]
| all (\t -> t =: ('ABC'.Annotation _)) before = ss
| otherwise = skipUntilEntryPoint $ tl ss
where
@@ -220,11 +225,31 @@ getType e = getTypeResolver >>= \tr -> case type tr e of
Just (Ok t) -> pure $ t
checkType :: Type Expression -> Gen ()
-checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e)
+checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e t`)
checkTypeName :: Name Expression -> Gen Type
checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`
+tellAbort :: String -> Gen ()
+tellAbort s = tell
+ [ 'ABC'.Raw $ "\tbuildAC\t\"" <+ quote s <+ "\\r\\n\""
+ , 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
+ , 'ABC'.Jsr "print_string_"
+ , 'ABC'.Annotation $ 'ABC'.OAnnot 0 []
+ , 'ABC'.Halt
+ ]
+where
+ quote :: (String -> String)
+ quote = toString o q o fromString
+ where
+ q :: [Char] -> [Char]
+ q [] = []
+ q ['\\':cs] = ['\\':'\\':q cs]
+ q ['\r':cs] = ['\\':'r' :q cs]
+ q ['\n':cs] = ['\\':'n' :q cs]
+ q ['\t':cs] = ['\\':'t' :q cs]
+ q [c:cs] = [c :q cs]
+
class gen a :: a -> Gen ()
instance gen Program
@@ -483,6 +508,11 @@ where
, 'ABC'.PushB False ] *>
growStack {zero & bsize=1} *>
tell [ 'ABC'.Label end ]
+ gen (BuiltinApp2 e1 Cons e2) =
+ genToAStack e2 *>
+ genToAStack e1 *>
+ tell [ 'ABC'.Raw "\tbuildh\t_Cons\t2" ] *>
+ shrinkStack {zero & asize=1}
gen (BuiltinApp2 e1 op e2) =
mapM gen [e2,e1] *>
gen op
@@ -491,6 +521,10 @@ where
mapM genToAStack (reverse es) *>
tell [ 'ABC'.Raw $ "\tbuildh\t_Tuple\t" <+ i ] *>
shrinkStack {zero & asize=i-1}
+ gen (List _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
+ gen (List t [e:es]) =
+ getType e >>= \te ->
+ gen (BuiltinApp2 e Cons (List (t <|> pure te) es))
gen e=:(Field f e`)
| isTuple =
getType e` >>= \t=:(TTuple arity tes) ->
@@ -498,12 +532,39 @@ where
tell [ 'ABC'.ReplArgs arity arity
, 'ABC'.Pop_a (tupleEl - 1)
, 'ABC'.Update_a 0 (arity - tupleEl)
- , 'ABC'.Pop_a (arity - tupleEl)
- ] *>
+ , 'ABC'.Pop_a (arity - tupleEl) ] *>
if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField f t) nop *>
case typeSize $ tes!!(tupleEl - 1) of
{bsize=0} -> nop
{btypes} -> mapM (flip toBStack 1) btypes *> nop
+ | f == "hd" =
+ fresh "iscons" >>= \iscons ->
+ gen e` *>
+ tell [ 'ABC'.EqDescArity "_Cons" 2 0
+ , 'ABC'.JmpTrue iscons ] *>
+ tellAbort "hd of empty list" *>
+ tell [ 'ABC'.Label iscons
+ , 'ABC'.ReplArgs 2 2
+ , 'ABC'.Update_a 0 1
+ , 'ABC'.Pop_a 1 ] *>
+ getType e >>= \te ->
+ case typeSize te of
+ {bsize=0} -> nop
+ {btypes} -> mapM (flip toBStack 1) btypes *> nop
+ | f == "tl" =
+ fresh "iscons" >>= \iscons ->
+ gen e` *>
+ tell [ 'ABC'.EqDescArity "_Cons" 2 0
+ , 'ABC'.JmpTrue iscons ] *>
+ tellAbort "tl of empty list" *>
+ tell [ 'ABC'.Label iscons
+ , 'ABC'.ReplArgs 2 2
+ , 'ABC'.Pop_a 1 ]
+ | f == "nil" =
+ gen e` *>
+ tell [ 'ABC'.EqDescArity "_Nil" 0 0
+ , 'ABC'.Pop_a 1 ] *>
+ growStack {asize=(-1), bsize=1, btypes=['ABC'.BT_Bool]}
| otherwise =
error $ C_UndefinedField f
where
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
index 15a660a..7df1976 100644
--- a/Sil/Error.dcl
+++ b/Sil/Error.dcl
@@ -21,7 +21,7 @@ from Sil.Types import :: Type
| C_FunctionOnStack
| C_TypeError Error Expression
| C_CouldNotDeduceType Expression
- | C_TypeMisMatch Type Expression
+ | C_TypeMisMatch Type Expression Type
| C_BasicInitWithoutValue String
// Miscellaneous
| UnknownError String
diff --git a/Sil/Error.icl b/Sil/Error.icl
index 6a9d07e..9c48ecc 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -21,7 +21,7 @@ where
toString C_FunctionOnStack = "Function stored on the stack."
toString (C_TypeError err e) = "Type error in '" <+ e <+ "': " <+ err
toString (C_CouldNotDeduceType e) = "Could not deduce type of '" <+ e <+ "'."
- toString (C_TypeMisMatch t e) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'."
+ toString (C_TypeMisMatch t e t`) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ t` <+ "."
toString (C_BasicInitWithoutValue n) = "Basic value '" <+ n <+ "' must have an initial value."
toString (UnknownError e) = "Unknown error: " <+ e <+ "."
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 441bf9e..378586a 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -11,9 +11,12 @@ from Sil.Util.Parser import class name
:: Token
= TParenOpen //* (
| TParenClose //* )
+ | TBrackOpen //* [
+ | TBrackClose //* ]
| TBraceOpen //* {
| TBraceClose //* }
| TComma //* ,
+ | TColon //* :
| TSemicolon //* ;
| TField String //* . and field name
| TAssign //* :=
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index c9521bf..cdd117f 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -33,9 +33,12 @@ instance toString Token
where
toString TParenOpen = "("
toString TParenClose = ")"
+ toString TBrackOpen = "["
+ toString TBrackClose = "]"
toString TBraceOpen = "{"
toString TBraceClose = "}"
toString TComma = ","
+ toString TColon = ":"
toString TSemicolon = ";"
toString (TField f) = "." +++ f
toString TAssign = ":="
@@ -78,9 +81,12 @@ where
tks ['&':'&':r] t = tks r [TDoubleAmpersand:t]
tks ['(':r] t = tks r [TParenOpen :t]
tks [')':r] t = tks r [TParenClose :t]
+ tks ['[':r] t = tks r [TBrackOpen :t]
+ tks [']':r] t = tks r [TBrackClose :t]
tks ['{':r] t = tks r [TBraceOpen :t]
tks ['}':r] t = tks r [TBraceClose :t]
tks [',':r] t = tks r [TComma :t]
+ tks [':':r] t = tks r [TColon :t]
tks [';':r] t = tks r [TSemicolon :t]
tks ['!':r] t = tks r [TExclamation:t]
tks ['~':r] t = tks r [TTilde :t]
@@ -192,15 +198,12 @@ expression
= rightAssoc (op TDoubleBar LogOr)
$ rightAssoc (op TDoubleAmpersand LogAnd)
$ rightAssoc (op TDoubleEquals Equals)
- $ leftAssoc
- ( op TPlus Add
- <|> op TMinus Sub
- )
- $ leftAssoc
- ( op TStar Mul
- <|> op TSlash Div
- <|> op TPercent Rem
- )
+ $ rightAssoc (op TColon Cons)
+ $ leftAssoc (op TPlus Add
+ <|> op TMinus Sub)
+ $ leftAssoc (op TStar Mul
+ <|> op TSlash Div)
+ $ leftAssoc (op TPercent Rem)
$ noInfix
where
op :: Token Op2 -> Parser Token Op2
@@ -219,7 +222,7 @@ where
= liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
<|> op TTilde Neg
<|> op TExclamation Not
- <|> (simpleExpr >>= \e -> many field >>= \fs -> pure $ foldr Field e fs)
+ <|> (simpleExpr >>= \e -> foldl (flip Field) e <$> many field)
where
op :: Token Op1 -> Parser Token Expression
op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
@@ -231,6 +234,8 @@ where
simpleExpr = liftM Literal literal
<|> liftM Name name
<|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es)
+ <|> flip List [] o pure <$> bracked type
+ <|> List Nothing <$> bracked (seplist TComma expression)
<|> parenthised expression
name :: Parser Token Name
@@ -249,6 +254,7 @@ type
<|> simpletype "Int" TInt
<|> simpletype "Void" TVoid
<|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
+ <|> TList <$> bracked type
<?> P_Expected "type"
where
simpletype s t = item (TName s) $> t
@@ -263,6 +269,9 @@ where
parenthised :: (Parser Token a) -> Parser Token a
parenthised p = item TParenOpen *> p <* item TParenClose
+bracked :: (Parser Token a) -> Parser Token a
+bracked p = item TBrackOpen *> p <* item TBrackClose
+
braced :: (Parser Token a) -> Parser Token a
braced p = item TBraceOpen *> p <* item TBraceClose
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 0f15930..e3a458d 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,8 +47,9 @@ from Sil.Types import :: Type
| App Name [Expression]
| BuiltinApp Op1 Expression
| BuiltinApp2 Expression Op2 Expression
- | Tuple Int [Expression]
| Field Name Expression
+ | Tuple Int [Expression]
+ | List (Maybe Type) [Expression]
:: Op1
= Neg //* ~
@@ -63,6 +64,7 @@ from Sil.Types import :: Type
| Equals //* ==
| LogOr //* ||
| LogAnd //* &&
+ | Cons //* :
:: Literal
= BLit Bool
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index cc5c3ba..53384b3 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -32,7 +32,10 @@ where
toString (BuiltinApp op e) = op <+ "(" <+ e <+ ")"
toString (BuiltinApp2 e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
toString (Tuple _ es) = "(" <+ printersperse ", " es <+ ")"
- toString (Field f e) = e <+ "." <+ f
+ toString (List (Just t) []) = "[" <+ t <+ "]"
+ toString (List (Just t) es) = "[" <+ t <+ ":" <+ printersperse ", " es <+ "]"
+ toString (List Nothing es) = "[" <+ printersperse ", " es <+ "]"
+ toString (Field f e) = "(" <+ e <+ ")." <+ f
instance toString Op1
where
@@ -49,6 +52,7 @@ where
toString Equals = "=="
toString LogOr = "||"
toString LogAnd = "&&"
+ toString Cons = ":"
instance toString Literal
where
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
index 51d4229..14602d3 100644
--- a/Sil/Types.dcl
+++ b/Sil/Types.dcl
@@ -16,6 +16,7 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
| TVoid
| (-->) infixr Type Type
| TTuple Int [Type]
+ | TList Type
:: TypeSize =
{ asize :: Int
diff --git a/Sil/Types.icl b/Sil/Types.icl
index e314342..ba13cba 100644
--- a/Sil/Types.icl
+++ b/Sil/Types.icl
@@ -33,6 +33,7 @@ where
toString TVoid = "Void"
toString (at --> rt) = "(" <+ at <+ " -> " <+ rt <+ ")"
toString (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
+ toString (TList t) = "[" <+ t <+ "]"
instance zero TypeSize where zero = {asize=0, bsize=0, btypes=[]}
@@ -41,6 +42,7 @@ typeSize TVoid = zero
typeSize TBool = {zero & bsize=1, btypes=[BT_Bool]}
typeSize TInt = {zero & bsize=1, btypes=[BT_Int]}
typeSize (TTuple _ _) = {zero & asize=1}
+typeSize (TList _) = {zero & asize=1}
(+~) infixl 6 :: TypeSize TypeSize -> TypeSize
(+~) a b =
@@ -78,6 +80,13 @@ where
type res op >>= \top -> pure
( top >>= \top ->
te >>= \te -> tryApply top te)
+ type res (BuiltinApp2 e1 Cons e2) =
+ type res e1 >>= \te1 ->
+ type res e2 >>= \te2 -> pure
+ ( te1 >>= \te1 ->
+ te2 >>= \te2 ->
+ let top = te1 --> TList te1 --> TList te1 in
+ foldM tryApply top [te1,te2])
type res (BuiltinApp2 e1 op e2) =
type res e1 >>= \te1 ->
type res e2 >>= \te2 ->
@@ -85,6 +94,17 @@ where
( top >>= \top ->
te1 >>= \te1 ->
te2 >>= \te2 -> foldM tryApply top [te1,te2])
+ type res e=:(List (Just t) es) =
+ mapM (type res) es >>= \tes -> pure
+ (sequence tes >>= \tes -> case [(e,t`) \\ e <- es & t` <- tes | t <> t`] of
+ [(e`,t`):_] -> Error $ C_TypeMisMatch t e` t`
+ [] -> Ok $ TList t)
+ type res (List Nothing []) = Nothing
+ type res e=:(List Nothing es) =
+ mapM (type res) es >>= \tes -> pure
+ (sequence tes >>= \tes -> case removeDup tes of
+ [t] -> Ok $ TList t
+ [_:_] -> Error $ C_CouldNotDeduceType e)
type res (Tuple n es)
| n > 32 = Just $ Error $ T_TooHighTupleArity n
| otherwise =
@@ -95,6 +115,15 @@ where
(Ok $ es!!(tupleEl - 1))
(Error $ T_IllegalField f te)
_ -> Error $ T_IllegalField f te)
+ | f == "hd" = type res e >>= \te -> pure (te >>= \te -> case te of
+ TList t -> Ok t
+ _ -> Error $ T_IllegalField f te)
+ | f == "tl" = type res e >>= \te -> pure (te >>= \te -> case te of
+ t=:(TList _) -> Ok t
+ _ -> Error $ T_IllegalField f te)
+ | f == "nil" = type res e >>= \te -> pure (te >>= \te -> case te of
+ (TList _) -> Ok TBool
+ _ -> Error $ T_IllegalField f te)
| otherwise = type res e >>= \te -> pure (te >>= Error o T_IllegalField f)
where
f` = fromString f
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:35:47 +0000