diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-05-14 01:40:54 +0200 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-05-14 01:40:54 +0200 |
commit | 472c3b8d66c3f3065e8a6715c59c5295cb16d435 (patch) | |
tree | 46578cc49b2084bd6a8945bd3ab7612baa10d7bc /src/LambdaCube/Compiler | |
parent | feeac006f966a7e2d621985d9c3eb2c45d2dbdb0 (diff) |
refactoring
Diffstat (limited to 'src/LambdaCube/Compiler')
-rw-r--r-- | src/LambdaCube/Compiler/Core.hs | 128 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/DesugaredSource.hs | 5 |
2 files changed, 70 insertions, 63 deletions
diff --git a/src/LambdaCube/Compiler/Core.hs b/src/LambdaCube/Compiler/Core.hs index ecc8cf07..3fca8b45 100644 --- a/src/LambdaCube/Compiler/Core.hs +++ b/src/LambdaCube/Compiler/Core.hs | |||
@@ -462,76 +462,75 @@ instance MkDoc Neutral where | |||
462 | MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i | 462 | MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i |
463 | -} | 463 | -} |
464 | 464 | ||
465 | mkFunDef a@(show -> "primFix") t = fn | 465 | mkFunDef a@(FTag FprimFix) t = fn |
466 | where | 466 | where |
467 | fn = FunName a 0 (DeltaDef (length $ fst $ getParams t) fx) t | 467 | fn = FunName a 0 (DeltaDef (length $ fst $ getParams t) fx) t |
468 | fx s xs = Neut $ Fun_ s fn xs $ case xs of | 468 | fx s xs = Neut $ Fun_ s fn xs $ case xs of |
469 | f: _{-1-} -> RHS x where x = f `app_` Neut (Fun_ s fn xs $ RHS x) | 469 | f: _{-1-} -> RHS x where x = f `app_` Neut (Fun_ s fn xs $ RHS x) |
470 | _ -> delta | 470 | _ -> delta |
471 | 471 | ||
472 | mkFunDef a t = fn | 472 | mkFunDef a@(FTag tag) t = fn |
473 | where | ||
474 | fn = FunName a 0 (maybe NoDef (DeltaDef (length $ fst $ getParams t) . const) $ getFunDef t a $ \xs -> Neut $ Fun fn xs delta) t | ||
475 | |||
476 | -- TODO: don't use show? | ||
477 | getFunDef t s f = case show s of | ||
478 | "'EqCT" -> Just $ \case (b: a: t: _) -> cstr t a b | ||
479 | "'T2" -> Just $ \case (b: a: _) -> t2 a b | ||
480 | "'CW" -> Just $ \case (a: _) -> cw a | ||
481 | "t2C" -> Just $ \case (b: a: _) -> t2C a b | ||
482 | "coe" -> Just $ \case (d: t: b: a: _) -> evalCoe a b t d | ||
483 | "parEval" -> Just $ \case (b: a: t: _) -> parEval t a b | ||
484 | where | ||
485 | parEval _ x@RHS{} _ = x | ||
486 | parEval _ _ x@RHS{} = x | ||
487 | parEval t a b = ParEval t a b | ||
488 | |||
489 | "unsafeCoerce" -> Just $ \case xs@(x@(hnf -> NonNeut): _{-2-}) -> x; xs -> f xs | ||
490 | "reflCstr" -> Just $ \case _ -> TT | ||
491 | "hlistNilCase" -> Just $ \case ((hnf -> Con n@(ConName _ 0 _) _ _): x: _{-1-}) -> x; xs -> f xs | ||
492 | "hlistConsCase" -> Just $ \case ((hnf -> Con n@(ConName _ 1 _) _ (b: a: _{-2-})): x: _{-3-}) -> x `app_` a `app_` b; xs -> f xs | ||
493 | |||
494 | -- general compiler primitives | ||
495 | "primAddInt" -> Just $ \case (HInt j: HInt i: _) -> HInt (i + j); xs -> f xs | ||
496 | "primSubInt" -> Just $ \case (HInt j: HInt i: _) -> HInt (i - j); xs -> f xs | ||
497 | "primModInt" -> Just $ \case (HInt j: HInt i: _) -> HInt (i `mod` j); xs -> f xs | ||
498 | "primSqrtFloat" -> Just $ \case (HFloat i: _) -> HFloat $ sqrt i; xs -> f xs | ||
499 | "primRound" -> Just $ \case (HFloat i: _) -> HInt $ round i; xs -> f xs | ||
500 | "primIntToFloat" -> Just $ \case (HInt i: _) -> HFloat $ fromIntegral i; xs -> f xs | ||
501 | "primIntToNat" -> Just $ \case (HInt i: _) -> ENat $ fromIntegral i; xs -> f xs | ||
502 | "primCompareInt" -> Just $ \case (HInt y: HInt x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
503 | "primCompareFloat" -> Just $ \case (HFloat y: HFloat x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
504 | "primCompareChar" -> Just $ \case (HChar y: HChar x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
505 | "primCompareString" -> Just $ \case (HString y: HString x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
506 | |||
507 | -- LambdaCube 3D specific primitives | ||
508 | "PrimGreaterThan" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>) x y -> r; xs -> f xs | ||
509 | "PrimGreaterThanEqual" | ||
510 | -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>=) x y -> r; xs -> f xs | ||
511 | "PrimLessThan" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<) x y -> r; xs -> f xs | ||
512 | "PrimLessThanEqual" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<=) x y -> r; xs -> f xs | ||
513 | "PrimEqualV" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs | ||
514 | "PrimNotEqualV" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs | ||
515 | "PrimEqual" -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs | ||
516 | "PrimNotEqual" -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs | ||
517 | "PrimSubS" -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (-) x y -> r; xs -> f xs | ||
518 | "PrimSub" -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (-) x y -> r; xs -> f xs | ||
519 | "PrimAddS" -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (+) x y -> r; xs -> f xs | ||
520 | "PrimAdd" -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (+) x y -> r; xs -> f xs | ||
521 | "PrimMulS" -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (*) x y -> r; xs -> f xs | ||
522 | "PrimMul" -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (*) x y -> r; xs -> f xs | ||
523 | "PrimDivS" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs | ||
524 | "PrimDiv" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs | ||
525 | "PrimModS" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs | ||
526 | "PrimMod" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs | ||
527 | "PrimNeg" -> Just $ \case (x: _{-1-}) | Just r <- oneOp negate x -> r; xs -> f xs | ||
528 | "PrimAnd" -> Just $ \case (EBool y: EBool x: _) -> EBool (x && y); xs -> f xs | ||
529 | "PrimOr" -> Just $ \case (EBool y: EBool x: _) -> EBool (x || y); xs -> f xs | ||
530 | "PrimXor" -> Just $ \case (EBool y: EBool x: _) -> EBool (x /= y); xs -> f xs | ||
531 | "PrimNot" -> Just $ \case (EBool x: _: _: (hnf -> TNat): _) -> EBool $ not x; xs -> f xs | ||
532 | |||
533 | _ -> Nothing | ||
534 | where | 473 | where |
474 | f xs = Neut $ Fun fn xs delta | ||
475 | fn = FunName a 0 (maybe NoDef (DeltaDef (length $ fst $ getParams t) . const) $ getFunDef tag) t | ||
476 | |||
477 | getFunDef = \case | ||
478 | F'EqCT -> Just $ \case (b: a: t: _) -> cstr t a b | ||
479 | F'T2 -> Just $ \case (b: a: _) -> t2 a b | ||
480 | F'CW -> Just $ \case (a: _) -> cw a | ||
481 | Ft2C -> Just $ \case (b: a: _) -> t2C a b | ||
482 | Fcoe -> Just $ \case (d: t: b: a: _) -> evalCoe a b t d | ||
483 | FparEval -> Just $ \case (b: a: t: _) -> parEval t a b | ||
484 | where | ||
485 | parEval _ x@RHS{} _ = x | ||
486 | parEval _ _ x@RHS{} = x | ||
487 | parEval t a b = ParEval t a b | ||
488 | |||
489 | FunsafeCoerce -> Just $ \case xs@(x@(hnf -> NonNeut): _{-2-}) -> x; xs -> f xs | ||
490 | FreflCstr -> Just $ \case _ -> TT | ||
491 | FhlistNilCase -> Just $ \case ((hnf -> Con n@(ConName _ 0 _) _ _): x: _{-1-}) -> x; xs -> f xs | ||
492 | FhlistConsCase -> Just $ \case ((hnf -> Con n@(ConName _ 1 _) _ (b: a: _{-2-})): x: _{-3-}) -> x `app_` a `app_` b; xs -> f xs | ||
493 | |||
494 | -- general compiler primitives | ||
495 | FprimAddInt -> Just $ \case (HInt j: HInt i: _) -> HInt (i + j); xs -> f xs | ||
496 | FprimSubInt -> Just $ \case (HInt j: HInt i: _) -> HInt (i - j); xs -> f xs | ||
497 | FprimModInt -> Just $ \case (HInt j: HInt i: _) -> HInt (i `mod` j); xs -> f xs | ||
498 | FprimSqrtFloat -> Just $ \case (HFloat i: _) -> HFloat $ sqrt i; xs -> f xs | ||
499 | FprimRound -> Just $ \case (HFloat i: _) -> HInt $ round i; xs -> f xs | ||
500 | FprimIntToFloat -> Just $ \case (HInt i: _) -> HFloat $ fromIntegral i; xs -> f xs | ||
501 | FprimIntToNat -> Just $ \case (HInt i: _) -> ENat $ fromIntegral i; xs -> f xs | ||
502 | FprimCompareInt -> Just $ \case (HInt y: HInt x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
503 | FprimCompareFloat -> Just $ \case (HFloat y: HFloat x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
504 | FprimCompareChar -> Just $ \case (HChar y: HChar x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
505 | FprimCompareString -> Just $ \case (HString y: HString x: _) -> mkOrdering $ x `compare` y; xs -> f xs | ||
506 | |||
507 | -- LambdaCube 3D specific primitives | ||
508 | FPrimGreaterThan -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>) x y -> r; xs -> f xs | ||
509 | FPrimGreaterThanEqual | ||
510 | -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>=) x y -> r; xs -> f xs | ||
511 | FPrimLessThan -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<) x y -> r; xs -> f xs | ||
512 | FPrimLessThanEqual -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<=) x y -> r; xs -> f xs | ||
513 | FPrimEqualV -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs | ||
514 | FPrimNotEqualV -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs | ||
515 | FPrimEqual -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs | ||
516 | FPrimNotEqual -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs | ||
517 | FPrimSubS -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (-) x y -> r; xs -> f xs | ||
518 | FPrimSub -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (-) x y -> r; xs -> f xs | ||
519 | FPrimAddS -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (+) x y -> r; xs -> f xs | ||
520 | FPrimAdd -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (+) x y -> r; xs -> f xs | ||
521 | FPrimMulS -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (*) x y -> r; xs -> f xs | ||
522 | FPrimMul -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (*) x y -> r; xs -> f xs | ||
523 | FPrimDivS -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs | ||
524 | FPrimDiv -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs | ||
525 | FPrimModS -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs | ||
526 | FPrimMod -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs | ||
527 | FPrimNeg -> Just $ \case (x: _{-1-}) | Just r <- oneOp negate x -> r; xs -> f xs | ||
528 | FPrimAnd -> Just $ \case (EBool y: EBool x: _) -> EBool (x && y); xs -> f xs | ||
529 | FPrimOr -> Just $ \case (EBool y: EBool x: _) -> EBool (x || y); xs -> f xs | ||
530 | FPrimXor -> Just $ \case (EBool y: EBool x: _) -> EBool (x /= y); xs -> f xs | ||
531 | FPrimNot -> Just $ \case (EBool x: _: _: (hnf -> TNat): _) -> EBool $ not x; xs -> f xs | ||
532 | |||
533 | _ -> Nothing | ||
535 | 534 | ||
536 | twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Maybe Exp | 535 | twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Maybe Exp |
537 | twoOpBool f (HFloat x) (HFloat y) = Just $ EBool $ f x y | 536 | twoOpBool f (HFloat x) (HFloat y) = Just $ EBool $ f x y |
@@ -557,6 +556,9 @@ getFunDef t s f = case show s of | |||
557 | 556 | ||
558 | modF x y = x - fromIntegral (floor (x / y)) * y | 557 | modF x y = x - fromIntegral (floor (x / y)) * y |
559 | 558 | ||
559 | mkFunDef a t = FunName a 0 NoDef t | ||
560 | |||
561 | |||
560 | evalCaseFun _ a ps (Con n@(ConName _ i _) _ vs) | 562 | evalCaseFun _ a ps (Con n@(ConName _ i _) _ vs) |
561 | | i /= (-1) = foldlrev app_ (ps !!! (i + 1)) vs | 563 | | i /= (-1) = foldlrev app_ (ps !!! (i + 1)) vs |
562 | | otherwise = error "evcf" | 564 | | otherwise = error "evcf" |
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs index c02fc7ca..db2c1f24 100644 --- a/src/LambdaCube/Compiler/DesugaredSource.hs +++ b/src/LambdaCube/Compiler/DesugaredSource.hs | |||
@@ -210,6 +210,11 @@ data FNameTag | |||
210 | -- functions | 210 | -- functions |
211 | | Fcoe | FparEval | Ft2C | FprimFix | 211 | | Fcoe | FparEval | Ft2C | FprimFix |
212 | | Fparens | FtypeAnn | Fundefined | Fotherwise | FprimIfThenElse | FfromTo | FconcatMap | FfromInt | Fproject | Fswizzscalar | Fswizzvector | 212 | | Fparens | FtypeAnn | Fundefined | Fotherwise | FprimIfThenElse | FfromTo | FconcatMap | FfromInt | Fproject | Fswizzscalar | Fswizzvector |
213 | |||
214 | | FunsafeCoerce | FreflCstr | FhlistNilCase | FhlistConsCase | ||
215 | | FprimAddInt | FprimSubInt | FprimModInt | FprimSqrtFloat | FprimRound | FprimIntToFloat | FprimIntToNat | FprimCompareInt | FprimCompareFloat | FprimCompareChar | FprimCompareString | ||
216 | | FPrimGreaterThan | FPrimGreaterThanEqual | FPrimLessThan | FPrimLessThanEqual | FPrimEqualV | FPrimNotEqualV | FPrimEqual | FPrimNotEqual | FPrimSubS | FPrimSub | FPrimAddS | FPrimAdd | FPrimMulS | FPrimMul | FPrimDivS | FPrimDiv | FPrimModS | FPrimMod | FPrimNeg | FPrimAnd | FPrimOr | FPrimXor | FPrimNot | ||
217 | |||
213 | -- other | 218 | -- other |
214 | | F_rhs | F_section | 219 | | F_rhs | F_section |
215 | deriving (Eq, Ord, Show, Enum, Bounded) | 220 | deriving (Eq, Ord, Show, Enum, Bounded) |