content: {-# LANGUAGE CPP, OverloadedStrings #-}
  module Haste.PrimOps (genOp) where
  import Prelude hiding (LT, GT)
  import PrimOp
  import Haste.AST
  import Haste.Config
  
  -- | Dummy State# RealWorld value for where one is needed.
  defState :: Exp
  defState = litN 0
  
  -- | Generate primops.
  --   Many of these ops return lifted Bool values; however, no thunk is
  --   generated for them in order to conserve space and CPU time. This relies
  --   on the evaluation operation in the RTS being able to handle plain values
  --   as though they were thunks. If this were to change, all those ops MUST
  --   be changed to return thunks!
  genOp :: Config -> PrimOp -> [Exp] -> Either String (Exp)
  genOp cfg op xs =
    case op of
      -- negations
      IntNegOp       -> Right $ binOp Sub (litN 0) (head xs)
      DoubleNegOp    -> Right $ binOp Sub (litN 0) (head xs)
      FloatNegOp     -> Right $ binOp Sub (litN 0) (head xs)
      NotOp          -> Right $ not_ (head xs) -- bitwise
      NotIOp         -> Right $ not_ (head xs) -- bitwise
  
      -- Conversions
      ChrOp          -> Right $ head xs
      OrdOp          -> Right $ head xs
      Word2IntOp     -> Right $ binOp BitAnd (head xs) (litN 0xffffffff)
      Int2WordOp     -> Right $ binOp ShrL (head xs) (litN 0)
      Int2FloatOp    -> Right $ head xs
      Int2DoubleOp   -> Right $ head xs
      Word2FloatOp   -> Right $ head xs
      Word2DoubleOp  -> Right $ head xs
      Double2IntOp   -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff)
      Double2FloatOp -> Right $ head xs
      Float2IntOp    -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff)
      Float2DoubleOp -> Right $ head xs
      
      -- Narrowing ops
      Narrow8IntOp   -> Right $ binOp BitAnd (head xs) (lit (0xff :: Double))
      Narrow16IntOp  -> Right $ binOp BitAnd (head xs) (lit (0xffff :: Double))
      Narrow32IntOp  -> Right $ binOp BitAnd (head xs) (lit (0xffffffff :: Double))
      Narrow8WordOp  -> Right $ binOp BitAnd (head xs) (lit (0xff :: Double))
      Narrow16WordOp -> Right $ binOp BitAnd (head xs) (lit (0xffff :: Double))
      Narrow32WordOp -> Right $ binOp ShrL (binOp BitAnd (head xs) (lit (0xffffffff :: Double))) (litN 0)
  
      -- Char ops
      CharGtOp -> bOp GT
      CharGeOp -> bOp GTE
      CharEqOp -> bOp Eq
      CharNeOp -> bOp Neq
      CharLtOp -> bOp LT
      CharLeOp -> bOp LTE
  
      -- Int ops
      IntAddOp ->        intMath $ bOp Add
      IntSubOp ->        intMath $ bOp Sub
      IntMulOp ->        intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1)
      -- FIXME: this is correct but slow!
      IntMulMayOfloOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1)
      IntQuotOp ->       callF "quot"
      IntQuotRemOp ->    callF "quotRemI"
      IntRemOp ->        bOp Mod -- JS % operator is actually rem, not mod!
      IntAddCOp -> callF "addC"
      IntSubCOp -> callF "subC"
      ISllOp ->    bOp Shl
      ISraOp ->    bOp ShrA
      ISrlOp ->    bOp ShrL
      IntGtOp ->   bOp GT
      IntGeOp ->   bOp GTE
      IntLtOp ->   bOp LT
      IntLeOp ->   bOp LTE
      IntEqOp ->   bOp Eq
      IntNeOp ->   bOp Neq
      AndIOp ->    bOp BitAnd
      OrIOp ->     bOp BitOr
      XorIOp ->    bOp BitXor
  
      -- Word ops
      WordAddOp ->  wordMath $ bOp Add
      WordSubOp ->  wordMath $ bOp Sub
      WordMulOp ->  wordMath $ callF "imul"
      WordQuotOp -> callF "quot"
      WordQuotRemOp -> callF "quotRemI"
      WordRemOp ->  bOp Mod
      AndOp ->      wordMath $ bOp BitAnd
      OrOp ->       wordMath $ bOp BitOr
      XorOp ->      wordMath $ bOp BitXor
      SllOp ->      wordMath $ bOp Shl
      SrlOp ->      bOp ShrL
      WordGtOp ->   bOp GT
      WordGeOp ->   bOp GTE
      WordEqOp ->   bOp Eq
      WordNeOp ->   bOp Neq
      WordLtOp ->   bOp LT
      WordLeOp ->   bOp LTE
  
      -- Double ops
      DoubleExpOp    -> Right $ callForeign "Math.exp" xs
      DoubleLogOp    -> Right $ callForeign "Math.log" xs
      DoubleSqrtOp   -> Right $ callForeign "Math.sqrt" xs
      DoubleCosOp    -> Right $ callForeign "Math.cos" xs
      DoubleSinOp    -> Right $ callForeign "Math.sin" xs
      DoubleTanOp    -> Right $ callForeign "Math.tan" xs
      DoubleAcosOp   -> Right $ callForeign "Math.acos" xs
      DoubleAsinOp   -> Right $ callForeign "Math.asin" xs
      DoubleAtanOp   -> Right $ callForeign "Math.atan" xs
      DoubleCoshOp   -> Right $ callForeign "cosh" xs
      DoubleSinhOp   -> Right $ callForeign "sinh" xs
      DoubleTanhOp   -> Right $ callForeign "tanh" xs
      DoubleDecode_2IntOp -> Right $ callForeign "decodeDouble" xs
      DoubleGtOp ->    bOp GT
      DoubleGeOp ->    bOp GTE
      DoubleEqOp ->    bOp Eq
      DoubleNeOp ->    bOp Neq
      DoubleLtOp ->    bOp LT
      DoubleLeOp ->    bOp LTE
      DoubleAddOp ->   bOp Add
      DoubleSubOp ->   bOp Sub
      DoubleMulOp ->   bOp Mul
      DoubleDivOp ->   bOp Div
      DoublePowerOp -> callF "Math.pow"
  
      -- Float ops
      FloatExpOp     -> Right $ callForeign "Math.exp" xs
      FloatLogOp     -> Right $ callForeign "Math.log" xs
      FloatSqrtOp    -> Right $ callForeign "Math.sqrt" xs
      FloatCosOp     -> Right $ callForeign "Math.cos" xs
      FloatSinOp     -> Right $ callForeign "Math.sin" xs
      FloatTanOp     -> Right $ callForeign "Math.tan" xs
      FloatAcosOp    -> Right $ callForeign "Math.acos" xs
      FloatAsinOp    -> Right $ callForeign "Math.asin" xs
      FloatAtanOp    -> Right $ callForeign "Math.atan" xs
      FloatCoshOp    -> Right $ callForeign "cosh" xs
      FloatSinhOp    -> Right $ callForeign "sinh" xs
      FloatTanhOp    -> Right $ callForeign "tanh" xs
      FloatDecode_IntOp -> Right $ callForeign "decodeFloat" xs
      FloatGtOp ->  bOp GT
      FloatGeOp ->  bOp GTE
      FloatEqOp ->  bOp Eq
      FloatNeOp ->  bOp Neq
      FloatLtOp ->  bOp LT
      FloatLeOp ->  bOp LTE
      FloatAddOp -> bOp Add
      FloatSubOp -> bOp Sub
      FloatMulOp -> bOp Mul
      FloatDivOp -> bOp Div
      FloatPowerOp -> callF "Math.pow"
      
      -- Array ops
      NewArrayOp -> callF "newArr"
      SameMutableArrayOp -> fmap (thunk True . ret) $ bOp Eq
      ReadArrayOp -> Right $ index arr ix
      WriteArrayOp -> Right $ assignEx (index arr ix) rhs
        where (_arr:_ix:rhs:_) = xs
      SizeofArrayOp -> Right $ index (head xs) (litS "length")
      SizeofMutableArrayOp -> Right $ index (head xs) (litS "length")
      IndexArrayOp -> Right $ index arr ix
      UnsafeFreezeArrayOp -> Right $ head xs
      UnsafeThawArrayOp -> Right $ head xs
      -- TODO: copy, clone, freeze, thaw
      
      -- Byte Array ops
      NewByteArrayOp_Char      -> callF "newByteArr"
      NewPinnedByteArrayOp_Char-> callF "newByteArr"
      SameMutableByteArrayOp   -> fmap (thunk True . ret) $ bOp Eq
      IndexByteArrayOp_Char    -> readArr xs "i8"
      IndexByteArrayOp_Int     -> readArr xs "i32"
      IndexByteArrayOp_Int8    -> readArr xs "i8"
      IndexByteArrayOp_Int16   -> readArr xs "i16"
      IndexByteArrayOp_Int32   -> readArr xs "i32"
      IndexByteArrayOp_Word    -> readArr xs "w32"
      IndexByteArrayOp_Word8   -> readArr xs "w8"
      IndexByteArrayOp_Word16  -> readArr xs "w16"
      IndexByteArrayOp_Word32  -> readArr xs "w32"
      IndexByteArrayOp_WideChar-> readArr xs "w32"
      IndexByteArrayOp_Float   -> readArr xs "f32"
      IndexByteArrayOp_Double  -> readArr xs "f64"
      
      ReadByteArrayOp_Char     -> readArr xs "i8"
      ReadByteArrayOp_Int      -> readArr xs "i32"
      ReadByteArrayOp_Int8     -> readArr xs "i8"
      ReadByteArrayOp_Int16    -> readArr xs "i16"
      ReadByteArrayOp_Int32    -> readArr xs "i32"
      ReadByteArrayOp_Word     -> readArr xs "w32"
      ReadByteArrayOp_Word8    -> readArr xs "w8"
      ReadByteArrayOp_Word16   -> readArr xs "w16"
      ReadByteArrayOp_Word32   -> readArr xs "w32"
      ReadByteArrayOp_WideChar -> readArr xs "w32"
      ReadByteArrayOp_Float    -> readArr xs "f32"
      ReadByteArrayOp_Double   -> readArr xs "f64"
      
      WriteByteArrayOp_Char    -> writeArr xs "i8"
      WriteByteArrayOp_Int     -> writeArr xs "i32"
      WriteByteArrayOp_Int8    -> writeArr xs "i8"
      WriteByteArrayOp_Int16   -> writeArr xs "i16"
      WriteByteArrayOp_Int32   -> writeArr xs "i32"
      WriteByteArrayOp_Word    -> writeArr xs "w32"
      WriteByteArrayOp_Word8   -> writeArr xs "w8"
      WriteByteArrayOp_Word16  -> writeArr xs "w16"
      WriteByteArrayOp_Word32  -> writeArr xs "w32"
      WriteByteArrayOp_WideChar-> writeArr xs "w32"
      WriteByteArrayOp_Float   -> writeArr xs "f32"
      WriteByteArrayOp_Double  -> writeArr xs "f64"
      
      SizeofByteArrayOp        -> Right $ index (head xs) (litS "byteLength")
      SizeofMutableByteArrayOp -> Right $ index (head xs) (litS "byteLength")
      NewAlignedPinnedByteArrayOp_Char -> Right $ callForeign "newByteArr" [xs!!0]
      UnsafeFreezeByteArrayOp  -> Right $ head xs
      ByteArrayContents_Char   -> Right $ head xs
      
      -- Mutable variables
      NewMutVarOp -> callF "nMV"
      ReadMutVarOp -> callF "rMV"
      WriteMutVarOp -> callF "wMV"
      SameMutVarOp -> bOp Eq
      AtomicModifyMutVarOp -> callF "mMV"
      
      -- TVars - since there's no parallelism and no preemption, TVars behave
      -- just like normal IORefs.
      NewTVarOp   -> callF "nMV"
      ReadTVarOp  -> callF "rMV"
      WriteTVarOp -> callF "wMV"
      SameTVarOp  -> bOp Eq
  
      -- Pointer ops
      ReallyUnsafePtrEqualityOp -> bOp Eq
      WriteOffAddrOp_Char    -> writeOffAddr xs "i8"  1
      WriteOffAddrOp_Int     -> writeOffAddr xs "i32" 4
      WriteOffAddrOp_Int8    -> writeOffAddr xs "i8"  1
      WriteOffAddrOp_Int16   -> writeOffAddr xs "i16" 2
      WriteOffAddrOp_Int32   -> writeOffAddr xs "i32" 4
      WriteOffAddrOp_Int64   -> writeOffAddr64 xs
      WriteOffAddrOp_Word    -> writeOffAddr xs "w32" 4
      WriteOffAddrOp_Word8   -> writeOffAddr xs "w8"  1
      WriteOffAddrOp_Word16  -> writeOffAddr xs "w16" 2
      WriteOffAddrOp_Word32  -> writeOffAddr xs "w32" 4
      WriteOffAddrOp_Word64  -> writeOffAddr64 xs
      WriteOffAddrOp_WideChar-> writeOffAddr xs "w32" 4
      WriteOffAddrOp_Float   -> writeOffAddr xs "f32" 4
      WriteOffAddrOp_Double  -> writeOffAddr xs "f64" 8
      ReadOffAddrOp_Char     -> readOffAddr xs "i8"   1
      ReadOffAddrOp_Int      -> readOffAddr xs "i32"  4
      ReadOffAddrOp_Int8     -> readOffAddr xs "i8"   1
      ReadOffAddrOp_Int16    -> readOffAddr xs "i16"  2
      ReadOffAddrOp_Int32    -> readOffAddr xs "i32"  4
      ReadOffAddrOp_Int64    -> readOffAddr64 xs True
      ReadOffAddrOp_Word     -> readOffAddr xs "w32"  4
      ReadOffAddrOp_Word8    -> readOffAddr xs "w8"   1
      ReadOffAddrOp_Word16   -> readOffAddr xs "w16"  2
      ReadOffAddrOp_Word32   -> readOffAddr xs "w32"  4
      ReadOffAddrOp_Word64   -> readOffAddr64 xs False
      ReadOffAddrOp_WideChar -> readOffAddr xs "w32"  4
      ReadOffAddrOp_Float    -> readOffAddr xs "f32"  4
      ReadOffAddrOp_Double   -> readOffAddr xs "f64"  8
      AddrAddOp              -> callF "plusAddr"
      AddrSubOp              ->
          Right $ callForeign "plusAddr" [addr, binOp Sub (litN 0) off]
        where (addr:off:_) = xs
      AddrEqOp               -> callF "addrEq"
      AddrNeOp               ->
          Right $ binOp Sub (litN 0) $ callForeign "addrEq" [a, b]
        where (a:b:_) = xs
      AddrLtOp               -> callF "addrLT"
      AddrGtOp               -> callF "addrGT"
      AddrLeOp               ->
          Right $ binOp Sub (litN 0) $ callForeign "addrGT" [a, b]
        where (a:b:_) = xs
      AddrGeOp               ->
          Right $ binOp Sub (litN 0) $ callForeign "addrLT" [a, b]
        where (a:b:_) = xs
      Addr2IntOp             ->
          Right $ index x (litS "off")
        where
          (x:_) = xs
      AddrToAnyOp            -> Right $ head xs
  
      -- MVars
      NewMVarOp     -> callF "newMVar"
      TakeMVarOp    -> callF "takeMVar"
      TryTakeMVarOp -> callF "tryTakeMVar"
      PutMVarOp     -> callF "putMVar"
      TryPutMVarOp  -> callF "tryPutMVar"
      SameMVarOp    -> callF "sameMVar"
      IsEmptyMVarOp -> callF "isEmptyMVar"
  
      -- Stable names
      MakeStableNameOp  -> callF "makeStableName"
      EqStableNameOp    -> callF "eqStableName"
      StableNameToIntOp -> Right $ head xs
  
      -- Stable pointers - all pointers are stable in JS!
      MakeStablePtrOp   -> Right $ head xs
      EqStablePtrOp     -> bOp Eq
      DeRefStablePtrOp  -> Right $ head xs
  
      -- Weak pointers - no concern of GC in JS
      MkWeakOp            -> callF "mkWeak"
      MkWeakNoFinalizerOp -> callF "mkWeak"
      DeRefWeakOp         -> callF "derefWeak"
      FinalizeWeakOp      -> callF "finalizeWeak"
  
      -- Exception masking
      -- There's only one thread anyway, so async exceptions can't happen.
      MaskAsyncExceptionsOp   -> Right $ callSaturated (head xs) []
      UnmaskAsyncExceptionsOp -> Right $ callSaturated (head xs) []
      MaskStatus              -> Right $ litN 0
  
      -- Bitwise ops
      PopCntOp       -> Right $ callForeign "popCnt" [head xs]
      PopCnt8Op      -> Right $ callForeign "popCnt" [head xs]
      PopCnt16Op     -> Right $ callForeign "popCnt" [head xs]
      PopCnt32Op     -> Right $ callForeign "popCnt" [head xs]
      PopCnt64Op     -> Right $ callForeign "popCnt64" [head xs]
  
      ClzOp          -> Right $ callForeign "__clz" [litN 32, head xs]
      Clz8Op         -> Right $ callForeign "__clz" [litN 8,  head xs]
      Clz16Op        -> Right $ callForeign "__clz" [litN 16, head xs]
      Clz32Op        -> Right $ callForeign "__clz" [litN 32, head xs]
  
      CtzOp          -> Right $ callForeign "__ctz" [litN 32, head xs]
      Ctz8Op         -> Right $ callForeign "__ctz" [litN 8,  head xs]
      Ctz16Op        -> Right $ callForeign "__ctz" [litN 16, head xs]
      Ctz32Op        -> Right $ callForeign "__ctz" [litN 32, head xs]    
  
      -- Concurrency - only relevant in a threaded environment
      NoDuplicateOp  -> Right $ defState
      MyThreadIdOp   -> Right $ litN 0 -- thread ID is always 0
  
      -- Misc. ops
      DelayOp        -> Right $ defState
      SeqOp          -> Right $ eval $ head xs
      AtomicallyOp   -> Right $ callSaturated (xs !! 0) []
      -- Get the data constructor tag from a value.
      DataToTagOp    -> callF "dataToTag"
      -- Basically unsafeCoerce :: Int# -> <enumeration type>
      TagToEnumOp    -> Right $ head xs
      TouchOp        -> Right $ defState
      RaiseOp        -> callF "die"
      RaiseIOOp      -> callF "die"
      CatchOp        -> callF "jsCatch"
      x              -> Left $ "Unsupported PrimOp: " ++ showOutputable cfg x
    where
      (arr:ix:_) = xs
      
      writeArr (a:i:rhs:_) etype =
        Right $ assignEx (index (index (index a (litS "v")) (litS etype)) i) rhs
      writeArr _ _ =
        error "writeArray primop with too few arguments!"
  
      readArr (a:i:_) elemtype =
        Right $ index (index (index a (litS "v")) (litS elemtype)) i
      readArr _ _ =
        error "writeArray primop with too few arguments!"
  
      writeOffAddr (addr:off:rhs:_) etype esize =
        Right $ callForeign "writeOffAddr" [litS etype,litN esize,addr,off,rhs]
      writeOffAddr _ _ _ =
        error "writeOffAddr primop with too few arguments!"
      writeOffAddr64 (addr:off:rhs:_) =
        Right $ callForeign "writeOffAddr64" [addr, off, rhs]
      
      readOffAddr (addr:off:_) etype esize =
        Right $ callForeign "readOffAddr" [litS etype,litN esize,addr,off]
      readOffAddr _ _ _ =
        error "readOffAddr primop with too few arguments!"
      readOffAddr64 (addr:off:_) esigned =
        Right $ callForeign "readOffAddr64" [lit esigned, addr, off]
  
      callF f = Right $ callForeign f xs
      
      bOp bop =
        case xs of
          [x, y] -> Right $ binOp bop x y
          _      -> error $ "PrimOps.binOp failed! op is " ++ show bop
      
      -- Bitwise ops on words need to be unsigned; exploit the fact that >>> is!
      wordMath = fmap (\oper -> binOp ShrL oper (litN 0))
      intMath = fmap (wrapIntMath cfg)
  