diff options
Diffstat (limited to 'Sil/Compile.icl')
| -rw-r--r-- | Sil/Compile.icl | 69 |
1 files changed, 65 insertions, 4 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 |